diff options
| author | Miles Bader <miles@gnu.org> | 2007-12-06 09:51:45 +0000 |
|---|---|---|
| committer | Miles Bader <miles@gnu.org> | 2007-12-06 09:51:45 +0000 |
| commit | 0bd508417142ff377f34aec8dcec9438d9175c2c (patch) | |
| tree | 4d60fe09e5cebf7d79766b11e9cda8cc1c9dbb9b /lisp | |
| parent | 98fe991da804a42f53f6a5e84cd5eab18a82e181 (diff) | |
| parent | 9fb1ba8090da3528de56158a79bd3527d31c7f2f (diff) | |
| download | emacs-0bd508417142ff377f34aec8dcec9438d9175c2c.tar.gz | |
Merge from emacs--devo--0
Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-294
Diffstat (limited to 'lisp')
372 files changed, 27030 insertions, 4420 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ba0a5477f00..b1214e069bf 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,6 +1,1639 @@ -2007-11-12 Katsumi Yamaoka <yamaoka@jpl.org> +2007-12-06 Glenn Morris <rgm@gnu.org> - * ldefs-boot.el: Regenerate. + * progmodes/antlr-mode.el (antlr-keyword, antlr-syntax) + (antlr-ruledef, antlr-tokendef, antlr-ruleref-face) + (antlr-tokenref, antlr-literal): Inherit from standard font-lock + faces in non-light-background case. + + * add-log.el, dired-aux.el, font-lock.el, help-fns.el, ido.el: + * informat.el, emacs-lisp/bytecomp.el, emacs-lisp/gulp.el: + * emacs-lisp/tcover-ses.el, emacs-lisp/timer.el, emulation/edt.el: + * emulation/vi.el, emulation/viper-cmd.el: + * international/titdic-cnv.el, mail/emacsbug.el, progmodes/dcl.el: + * progmodes/prolog.el, progmodes/ps-mode.el, progmodes/python.el: + * textmodes/fill.el: Remove directory part from filenames in + function declarations. + + * dired-aux.el (mailcap-mime-info): Update declaration. + +2007-12-05 Richard Stallman <rms@gnu.org> + + * wid-edit.el (widget-type): Doc fix. + +2007-12-05 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/perl-mode.el (perl-font-lock-syntactic-keywords): + Don't match "sub { (...) ... }". + +2007-12-05 Richard Stallman <rms@gnu.org> + + * international/mule-cmds.el (toggle-input-method-active): New var. + (toggle-input-method): Bind toggle-input-method-active to t. + Error if it was already non-nil. + +2007-12-05 Reiner Steib <Reiner.Steib@gmx.de> + + * net/tls.el (tls-hostmismatch, open-tls-stream): Checkdoc cleanup. + +2007-12-05 Elias Oltmanns <eo@nebensachen.de> + + * net/tls.el (open-tls-stream): Actually consult tls-checktrust to + see if certs should be verified and what is to be done in the + event of a verification failure. + +2007-12-05 Reiner Steib <Reiner.Steib@gmx.de> + + * net/tls.el (tls-program): Provide more custom choices from + `tls-checktrust'. Refer to `tls-checktrust' in doc string. + (tls-process-connection-type, tls-success): Remove "*" in doc string. + (tls-checktrust, tls-hostmismatch, tls-untrusted): Add custom + version. Minor improvement to doc strings. + (tls-program): Add comment. + +2007-12-05 Elias Oltmanns <eo@nebensachen.de> + + * net/tls.el (tls-certtool-program, tls-hostmismatch): New variables. + (tls-checktrust): New variable. Check if GNU TLS complained about a + mismatch between the hostname provided in the certificate and the name + of the host connnecting to. + (open-tls-stream): Use them. Check certificates against trusted root + certificates. + +2007-12-05 Nathan J. Williams <nathanw@MIT.EDU> (tiny change) + + * net/imap.el (imap-mailbox-status-asynch): Upcase STATUS items. + (imap-parse-status): Upcase status-att for broken servers that sends + them lower-case (e.g., MS Exchange 2007). + +2007-12-05 D. Goel <deego3@gmail.com> + + * simple.el (undo): + * image-dired.el (image-dired-display-thumb-properties): + (image-dired-modify-mark-on-thumb-original-file): + (image-dired-dired-display-properties): + * help.el (help-window-display-message): + * files.el (hack-local-variables-confirm): + * ediff.el (ediff-version): + * complete.el (pc-chunk-after, PC-temp-minibuffer-message): + `message' and `error': Ensure that first arg is a format string. + + * emacs-lisp/find-func.el (find-library-name): Prefer files with + ".el" suffix over "". + +2007-12-05 Michael Albinus <michael.albinus@gmx.de> + + * net/dbus.el (dbus-hash-table=): Allow nil as wildcard in the + interface and member fields. + +2007-12-05 Glenn Morris <rgm@gnu.org> + + * eshell/em-alias.el (pcomplete-stub): Define for compiler. + (pcomplete-here): Autoload it. + + * eshell/em-basic.el (print-func): No need to define for compiler. + + * eshell/esh-cmd.el (eshell-debug-command): + * eshell/esh-io.el (eshell-print): Move definitions before use. + + * eshell/esh-module.el (eshell-load-defgroups): Eval and compile. + + * eshell/esh-util.el (top-level): Don't require pp. Use + condition-case rather than ignore-errors. + + * eshell/eshell.el (eshell-buffer-name): Define for compiler. + + * eshell/em-alias.el, eshell/em-banner.el, eshell/em-basic.el + * eshell/em-cmpl.el, eshell/em-dirs.el, eshell/em-glob.el + * eshell/em-hist.el, eshell/em-ls.el, eshell/em-pred.el + * eshell/em-prompt.el, eshell/em-rebind.el, eshell/em-script.el + * eshell/em-smart.el, eshell/em-term.el, eshell/em-unix.el + * eshell/em-xtra.el, eshell/esh-cmd.el, eshell/esh-test.el + * eshell/esh-util.el, eshell/eshell.el: Require individual files + if needed when compiling, rather than esh-maint. Collect any + require statements. Move provide statement to end. Move any + commentary to start. + + * eshell/esh-arg.el, eshell/esh-ext.el, eshell/esh-io.el: + * eshell/esh-mode.el, eshell/esh-module.el, eshell/esh-opt.el: + * eshell/esh-proc.el, eshell/esh-var.el: + Require individual files if needed when compiling, rather than + esh-maint. Collect any require statements. Leave provide at start. + Move any commentary to start. + + * emacs-lisp/bytecomp.el (byte-compile-declare-function): Remove + declared function from byte-compile-noruntime-functions. + + * ediff-util.el (ediff-version): + * progmodes/python.el (compilation-shell-minor-mode): + * textmodes/org.el (Info-goto-node, calendar-astro-date-string) + (calendar-bahai-date-string, calendar-check-holidays) + (calendar-chinese-date-string, calendar-coptic-date-string) + (calendar-ethiopic-date-string, calendar-forward-day) + (calendar-french-date-string, calendar-goto-date) + (calendar-goto-today, calendar-hebrew-date-string) + (calendar-islamic-date-string, calendar-iso-date-string) + (calendar-julian-date-string, calendar-mayan-date-string) + (calendar-persian-date-string, gnus-summary-last-subject) + (parse-time-string, rmail-show-message): Declare as functions. + +2007-12-05 Michael Olson <mwolson@gnu.org> + + * textmodes/remember.el: Merge contents of remember-diary.el here, + updating header. Add autoload cookie so that byte-compilation + works without warning. + (remember-diary-file): Default to nil, since diary might not yet + be loaded at this point, which would deny us access to diary-file. + (remember-diary-extract-entries): If remember-diary-file is nil, + then use diary-file instead. + + * textmodes/remember-diary.el: Remove, due to the issue of needing + the first 8 characters of a filename to be unique. + +2007-12-04 Michael Albinus <michael.albinus@gmx.de> + + * net/dbus.el (dbus-hash-table=): New defun. + (dbus-hash-table-test) New hash table test function, used in + `dbus-registered-functions-table'. + (dbus-check-event, dbus-handle-event, dbus-event-bus-name) + (dbus-event-service-name, dbus-event-path-name) + (dbus-event-interface-name, dbus-event-member-name): Rewritten, + due to new structure of `dbus-event'. + +2007-12-04 Juanma Barranquero <lekktu@gmail.com> + + * ido.el (ido-save-history): Set the `coding' local + variable in the first line of the file. + +2007-12-04 Glenn Morris <rgm@gnu.org> + + * password-cache.el: Move here from gnus/password.el. + (top-level): Don't require cl when compiling. + (password-read-and-add): Doc fix. Make obsolete. + + * net/tramp.el: Require password-cache or password. + + * emulation/cua-base.el (top-level): Move (provide 'cua-base) to end. + No longer provide 'cua. Don't require cua-rect, cua-gmrk when + compiling. + (cua-set-rectangle-mark): Add doc string to autoload. + (cua--rectangle, cua--last-killed-rectangle) + (cua--global-mark-active): Always define for compiler. + (cua-copy-rectangle, cua-cut-rectangle, cua--rectangle-left) + (cua--delete-rectangle, cua--insert-rectangle) + (cua--rectangle-corner, cua--rectangle-assert) + (cua--insert-at-global-mark, cua--global-mark-post-command): + Declare as functions. + + * emulation/cua-gmrk.el (top-level): Move provide to end. + + * emulation/cua-rect.el (top-level): Move provide to end. + Don't require cua-gmrk when compiling. + (cua--cut-rectangle-to-global-mark) + (cua--copy-rectangle-to-global-mark): Declare as functions. + + * emulation/viper-init.el (viper-replace-overlay-cursor-color) + (viper-insert-state-cursor-color, viper-emacs-state-cursor-color) + (viper-vi-state-cursor-color): + Consolidate make-variable-frame-local calls. + + * net/eudcb-bbdb.el (bbdb-address-streets): Declare as a function. + (eudc-bbdb-extract-addresses): Use bbdb-address-streets rather + than bbdb-address-street1,2,3. + + * textmodes/reftex-toc.el (reftex-make-separate-toc-frame): + Try x-focus-frame before focus-frame. Only try focus-frame on XEmacs. + +2007-12-03 Karl Fogel <kfogel@red-bean.com> + + * saveplace.el (save-place-quiet): Remove, reverting 2007-12-02T19:54:46Z!kfogel@red-bean.com. + (save-place-alist-to-file, load-save-place-alist-from-file): + Don't print non-error messages at all, there's really no need. + Do print if there's a problem, and clarify message in that case. + +2007-12-03 Dan Nicolaescu <dann@ics.uci.edu> + + * ediff-diff.el (ediff-prepare-error-list): + * ediff-util.el (ediff-setup): Disable undo for ediff-error-buffer. + +2007-12-03 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el (doc-view-initiate-display): Use `doc-view-mode-p'. + (doc-view-current-overlay, doc-view-pending-cache-flush): + Add doc string. + +2007-12-03 Richard Stallman <rms@gnu.org> + + * subr.el (declare-function): Moved from byte-run.el. + + * emacs-lisp/byte-run.el (declare-function): Moved to subr.el + + * window.el (recenter-top-bottom): Don't use `ecase'. + +2007-12-02 Karl Fogel <kfogel@red-bean.com> + + * saveplace.el (save-place-alist-to-file): Set + coding-system-for-write once and refer to it throughout. + Suggested by David Reitter <dreitter{_AT_}inf.ed.ac.uk>. + +2007-12-02 Karl Fogel <kfogel@red-bean.com> + + * saveplace.el (save-place-alist-to-file): Use `utf-8' coding + system when writing, and set it in the first-line file variables. + Suggested by David Reitter <dreitter{_AT_}inf.ed.ac.uk> and + Juanma Barranquero. + +2007-12-02 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/bytecomp.el (byte-compile-declare-function): + Reverse branches of if statement. + + * emulation/viper-cmd.el (top-level): Don't require advice. + Don't load viper-util, viper-keym, viper-mous, viper-macs, + viper-ex when compiling. + + * emulation/viper-ex.el (top-level): Don't load viper-util, + viper-keym when compiling. + + * emulation/viper-init.el (top-level): Move provide statement to end. + + * emulation/viper-keym.el (top-level): Don't load viper-util when + compiling. Move provide statement to end. + + * emulation/viper-macs.el (top-level): Don't load viper-util, + viper-keym, viper-mous when compiling. + + * emulation/viper-mous.el (top-level): Don't load viper-util when + compiling. + + * emulation/viper-util.el (top-level): Don't load viper-init when + compiling. + + * emulation/viper.el (top-level): Don't require ring. + Don't load viper-init, viper-cmd when compiling. + + * net/sasl-cram.el, net/sasl-digest.el, net/sasl-ntlm.el, net/sasl.el: + Move here from gnus/. + +2007-12-02 Karl Fogel <kfogel@red-bean.com> + + Offer option for saveplace to be quiet about loading and saving. + Suggested by David Reitter <dreitter{_AT_}inf.ed.ac.uk> + + * lisp/saveplace.el (save-place-quiet): New customizable boolean. + (save-place-alist-to-file, load-save-place-alist-from-file): Use it + to determine whether to print loading/saving messages. + +2007-12-02 Glenn Morris <rgm@gnu.org> + + * mail/binhex.el: Move here from gnus/. + (binhex): New custom group. + (binhex-decoder-program, binhex-decoder-switches) + (binhex-use-external): Move to the binhex custom group. + + * mail/uudecode.el: Move here from gnus/. + (uudecode): New custom group. + (uudecode-decoder-program, uudecode-decoder-switches) + (uudecode-use-external): Move to the uudecode custom group. + + * net/netrc.el (top-level): Don't load `encrypt' features. + (netrc-parse): Don't use encrypt. + (netrc-find-service-name, netrc-find-service-number): Don't use caddr. + + * progmodes/python.el (top-level): Don't require cl when compiling. + +2007-12-02 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> + + * textmodes/flyspell.el (flyspell-large-region): Explicitly set + encoding for aspell process and for communication with it. + Only add "-d" option if not already present. + Use ispell-current-dictionary and ispell-current-personal-dictionary. + General reorganization. + + * textmodes/ispell.el (ispell-aspell-find-dictionary): Do not set + encoding here. + (ispell-start-process): Explicitly set encoding here if using aspell. + +2007-12-02 Dan Nicolaescu <dann@ics.uci.edu> + + * pcvs.el (cvs-mode-commit, cvs-mode-edit-log): Also pass a diff + function to log-edit. + +2007-12-02 Michael Albinus <michael.albinus@gmx.de> + + * net/dbus.el: New file. + +2007-12-02 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc.el (calc-lang-slash-idiv, calc-lang-allow-underscores) + (calc-lang-c-type-hex, calc-lang-brackets-are-subscripts) + (calc-lang-parens-are-subscripts): New variables. + (math-expr-special-function-mapping): Remove variable. + (math-eqn-ignore-words, math-tex-ignore-words) + (math-latex-ignore-words): Move to calc-lang.el. + + * calc/calc-lang.el (math-compose-vector, math-compose-var) + (math-tex-expr-is-flat): Declare as functions. + (calc-lang-slash-idiv, calc-lang-allow-underscores) + (math-comp-left-bracket, math-comp-right-bracket) + (math-comp-comma, math-comp-vector-prec): Declare as variables. + (math-var-formatter, math-matrix-formatter) + (math-lang-adjust-words, math-lang-read-symbol, math-land-read) + (math-punc-table, math-compose-subscr,math-dots) + (math-func-formatter): New property names to store language + specific information. + (math-compose-tex-var, math-compose-tex-intv) + (math-compose-maple-intv, math-compose-eqn-intv) + (math-compose-tex-sum, math-compose-tex-func) + (math-compose-tex-intv): New functions. + (math-eqn-ignore-words,math-tex-ignore-words) + (math-latex-ignore-words): Move from calc.el. + (math-special-function-table): Add entries for tex. + (calc-lang-slash-idiv, calc-lang-allows-underscores): + New variables. + (math-compose-latex-frac): Rename from `math-latex-print-frac'. + (math-compose-tex-matrix, math-compose-eqn-matrix) + (math-eqn-special-functions): Move from calccomp.el. + + * calc/calccomp.el (math-compose-var): New function. + (math-compose-expr): Allow more special functions to be used. + Change test for formatting fractions. Use variables and property + names to help with language specific formatting. + (math-compose-tex-matrix, math-compose-eqn-matrix) + (math-eqn-special-functions): Move to calc-lang.el. + (math-compose-rows): Use property names to help with language + specific formatting. + + * calc/calc-aent.el (math-read-factor): Turn multiple subscripts + into nested subscripts. + (math-read-token): Use variables and property names to help with + language specific parsing. + (math-read-expression-level): Use variables to help with language + specific parsing. + +2007-12-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * arc-mode.el (archive-find-type): Add recognition of rar-exe format. + (archive-rar-summarize): Allow the file name to be passed as argument. + Remove unused vars `header' and `footer'. + (archive-rar-exe-summarize, archive-rar-exe-extract): New functions. + +2007-12-01 Dan Nicolaescu <dann@ics.uci.edu> + + * log-edit.el (log-edit-show-diff): New function. + (log-edit-mode-map, log-edit-menu): Bind it. + (log-edit-diff-function): New variable. + (log-edit): Change the 3rd param to be an alist and accept a + function that computes a diff for the files involved. + + * vc.el (vc-log-edit): Add a diff function parameter to log-edit. + +2007-12-01 Martin Rudalics <rudalics@gmx.at> + + * play/blackbox.el (bb-up, bb-down): Revert 2007-10-21 change and + wrap next-/previous-line in with-no-warnings. + +2007-12-01 Glenn Morris <rgm@gnu.org> + + * format-spec.el, hex-util.el, sha1.el: Move here from gnus/. + + * net/dig.el: Move here from gnus/. + (dig-mode): Replace gnus-run-mode-hooks with equivalent expansion. + + * net/dns.el: Move here from gnus/. + (top-level): Don't require mm-util, or cl when compiling. + (dns-write-name, dns-read, dns-read-type, query-dns): + Replace mm-with-unibyte-buffer with its expansion. + (query-dns): Replace decf and ignore-errors with non-cl equivalents. + + * progmodes/gdb-ui.el (gud-remove, gud-break): + * progmodes/gud.el (gdb-create-define-alist) + (gdb-restore-windows, gdb-reset, global-hl-line-highlight) + (hl-line-highlight, gdb-display-source-buffer) + (gdb-display-buffer, c-langelem-sym, c-langelem-pos) + (syntax-symbol, syntax-point, gdb-enqueue-input): Declare as functions. + +2007-11-30 Dan Nicolaescu <dann@ics.uci.edu> + + * textmodes/org-export-latex.el (org-export-latex-cleaned-string): + Move args on defun line. + + * textmodes/org.el (org-calendar-holiday): + Use calendar-check-holidays instead of the obsolete + check-calendar-holidays. + (add-to-diary-list, table--at-cell-p, Info-find-node, bbdb) + (bbdb-company, bbdb-current-record, bbdb-name) + (bbdb-record-getprop, bbdb-record-name) + (bibtex-beginning-of-entry, bibtex-generate-autokey) + (bibtex-parse-entry, bibtex-url, cdlatex-tab) + (dired-get-filename, gnus-article-show-summary, mh-display-msg) + (mh-find-path, mh-get-header-field, mh-get-msg-num) + (mh-header-display, mh-index-previous-folder) + (mh-normalize-folder-name, mh-search, mh-search-choose, mh-show) + (mh-show-buffer-message-number, mh-show-header-display) + (mh-show-msg, mh-show-show, mh-visit-folder) + (org-export-latex-cleaned-string, remember) + (remember-buffer-desc, rmail-narrow-to-non-pruned-header) + (rmail-what-message, elmo-folder-exists-p) + (elmo-message-entity-field, elmo-message-field) + (vm-beginning-of-message, vm-follow-summary-cursor) + (vm-get-header-contents, vm-isearch-narrow, vm-isearch-update) + (vm-select-folder-buffer, vm-su-message-id, vm-su-subject) + (vm-summarize, wl-folder-get-elmo-folder) + (wl-summary-goto-folder-subr) + (wl-summary-jump-to-msg-by-message-id, wl-summary-line-from) + (wl-summary-line-subject, wl-summary-message-number) + (wl-summary-redisplay): Declare as functions. + +2007-11-30 Martin Rudalics <rudalics@gmx.at> + + * longlines.el (longlines-show-hard-newlines): Remove handling of + buffer-undo-list and buffer-modified status. + (longlines-show-region, longlines-unshow-hard-newlines): + Handle buffer-undo-list, buffer-modified status, inhibit-read-only, and + inhibit-modification-hooks here to avoid that a buffer appears + modified when toggling visibility of hard newlines. + +2007-11-30 Glenn Morris <rgm@gnu.org> + + * nxml/rng-maint.el (rng-do-some-validation): Fix declaration. + + * progmodes/idlw-complete-structtag.el + (idlwave-sintern-structtag): + * progmodes/idlw-help.el (idlwave-sintern-sysvar) + (idlwave-sintern-sysvartag): + * progmodes/idlwave.el (idlwave-sintern-class-tag) + (idlwave-sintern-sysvar, idlwave-sintern-sysvartag): Declare as + functions. + +2007-11-30 Dan Nicolaescu <dann@ics.uci.edu> + + * textmodes/reftex-index.el (texmathp): + * textmodes/reftex-auc.el (TeX-argument-insert) + (TeX-argument-prompt, multi-prompt, LaTeX-add-index-entries) + (LaTeX-add-labels, LaTeX-bibitem-list, LaTeX-index-entry-list) + (LaTeX-label-list): + * nxml/rng-maint.el (rng-clear-cached-state, rng-clear-overlays) + (rng-clear-conditional-region, rng-do-some-validation): Declare as + functions. + (rng-error-count, rng-validate-up-to-date-end): Pacify byte compiler. + +2007-11-30 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/byte-run.el (declare-function): Add optional fourth + argument and document it. + + * emacs-lisp/bytecomp.el (byte-compile-declare-function): + Third argument to declare-function must be a list to specify arglist. + + * emacs-lisp/check-declare.el (check-declare-scan): Doc fix. + Handle declare-function third argument `t' and fourth argument. + (check-declare-verify): Doc fix. Handle `fileonly' case. + Use progn rather than prog1. + + * desktop.el (uniquify-item-base): + * term/mac-win.el (url-type): Declare as functions. + + * net/eudcb-bbdb.el (bbdb-phone-location, bbdb-record-phones) + (bbdb-address-city, bbdb-address-state, bbdb-address-zip) + (bbdb-address-location, bbdb-record-addresses): Pass non-nil + fourth arg to declare-function. + + * play/dunnet.el: Don't require cl when compiling. + (byte-compile-warnings): Set via file local variables. + (dun-parse): Let-bind `beg' and `line'. + +2007-11-29 Alexandre Julliard <julliard@winehq.org> + + * vc-git.el (vc-git-dir-state): Fix the git command arguments. + +2007-11-29 Ari Roponen <ari.roponen@gmail.com> (tiny change) + + * calendar/time-date.el (encode-time-value): Doc fix. + +2007-11-29 Glenn Morris <rgm@gnu.org> + + * calendar/time-date.el (with-decoded-time-value): Doc fix. + + * textmodes/css-mode.el (prog-mode): Remove. + (css-mode): Derive from fundamental-mode rather than prog-mode. + + * emacs-lisp/byte-run.el (declare-function): Doc fix. + + * emacs-lisp/check-declare.el (check-declare-locate) + (check-declare-verify): Handle `external' files. + (check-declare-errmsg): New function. + (check-declare-verify, check-declare-file, check-declare-directory): + Use check-declare-errmsg to report the number of problems. + + * ffap.el (w3-view-this-url) + * mail/mspools.el (vm-visit-folder) + * net/browse-url.el (w3-fetch-other-window, w3-fetch) + * net/eudcb-bbdb.el (bbdb-phone-location, bbdb-phone-string) + (bbdb-record-phones, bbdb-address-city, bbdb-address-state) + (bbdb-address-zip, bbdb-address-location, bbdb-record-addresses) + (bbdb-records) + * net/eudc-export.el (bbdb-parse-phone-number, bbdb-string-trim) + * net/imap.el (sasl-find-mechanism, sasl-mechanism-name) + (sasl-make-client, sasl-next-step, sasl-step-data) + (sasl-step-set-data) + * net/newsticker.el (w3m-toggle-inline-image, htmlr-reset) + (htmlr-step): Declare as functions. + + * net/eudcb-bbdb.el (eudc-bbdb-extract-addresses): + Use bbdb-address-zip rather than bbdb-address-zip-string. + +2007-11-28 Richard Stallman <rms@gnu.org> + + * md4.el, net/hmac-def.el, net/hmac-md5.el, net/ntlm.el: + Move here from gnus/. + +2007-11-28 Martin Rudalics <rudalics@gmx.at> + + * newcomment.el (comment-region-internal): Fix newline insertion + in `block' case. + +2007-11-28 Stefan Monnier <monnier@iro.umontreal.ca> + + * pcvs-parse.el (cvs-parse-table): Adjust regexp for resurrections. + +2007-11-28 Glenn Morris <rgm@gnu.org> + + * Makefile.in (maintainer-clean): Depend on bootstrap-clean to + delete .elc files. + + * nxml/char-name/unicode: Move to etc/nxml/. + * nxml/nxml-uchnm.el (top-level): Adapt for moved unicode files. + + * nxml/nxml-enc.el (xmltok-get-declared-encoding-position): + Declare as a function. + + * nxml/nxml-maint.el (nxml-create-unicode-char-name-sets): + * nxml/nxml-mode.el (nxml-get-char-name, nxml-insert-named-char): + * nxml/xsd-regexp.el (xsdre-gen-categories): Change mapcar -> mapc. + + * nxml/nxml-outln.el (nxml-token-start-tag-p) + (nxml-token-end-tag-p): Move definitions before use. + + * nxml/nxml-rap.el (nxml-prolog-regions): Declare for compiler. + + * nxml/nxml-uchnm.el (top-level) + (nxml-enable-unicode-char-name-sets-1): Use mapc rather than mapcar. + (nxml-enabled-unicode-blocks): Add custom group. + + * nxml/xmltok.el (xmltok-scan-char-ref, xmltok-char-number): + Use string-to-number rather than string-to-int. + + * dired-x.el (dired-omit-old-add-entry): Declare as function. + Move definition before use. + (dired-old-find-buffer-nocreate): Declare as function. + + * emacs-lisp/check-declare.el (check-declare-locate): Reflow doc. + (check-declare-verify): Handle fset. + + * emulation/edt.el (edt-user-emulation-setup): + Test edt-setup-user-bindings is bound before calling. + + * emulation/tpu-edt.el: Don't require cl when compiling. + (tpu-emacs-search, tpu-emacs-rev-search): Declare as functions. + (tpu-edt-off): Use condition-case rather than ignore-errors. + Use with-no-warnings. + + * eshell/esh-util.el (top-level): Use require rather than load for + ange-ftp. + + * mail/supercite.el (sc-version): Redefine as an alias for + emacs-version. + (sc-help-address): Remove. + (sc-version): Use emacs-version rather than sc-version. + (sc-submit-bug-report): Redefine as an alias for report-emacs-bug. + + * net/socks.el (socks-original-open-network-stream): Declare as + function. Move definition before use. + +2007-11-28 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-ext.el (math-sqrt-raw, math-map-vec) + (math-make-frac): Declare as functions. + +2007-11-27 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/cperl-mode.el (compilation-error-regexp-alist): + Pacify byte compiler. + (cperl-mode): Use with-no-warnings for setting vc-header-alist. + + * progmodes/idlwave.el (idlwave-shell-get-path-info) + (idlwave-shell-temp-file, idlwave-shell-is-running) + (widget-value, comint-dynamic-complete-filename, Info-goto-node): + * progmodes/idlw-help.el (idlwave-prepare-structure-tag-completion) + (idlwave-all-method-classes, idlwave-all-method-keyword-classes) + (idlwave-beginning-of-statement, idlwave-best-rinfo-assoc) + (idlwave-class-found-in, idlwave-class-or-superclass-with-tag) + (idlwave-completing-read, idlwave-current-routine) + (idlwave-downcase-safe, idlwave-entry-find-keyword) + (idlwave-expand-keyword, idlwave-find-class-definition) + (idlwave-find-inherited-class, idlwave-find-struct-tag) + (idlwave-get-buffer-visiting, idlwave-in-quote) + (idlwave-make-full-name, idlwave-members-only) + (idlwave-popup-select, idlwave-routine-source-file) + (idlwave-routines, idlwave-sintern-class) + (idlwave-sintern-keyword, idlwave-sintern-method) + (idlwave-sintern-routine-or-method) + (idlwave-substitute-link-target, idlwave-sys-dir) + (idlwave-this-word, idlwave-what-module-find-class) + (idlwave-where): + * progmodes/idlw-complete-structtag.el (idlwave-shell-buffer): + * mail/uce.el (rmail-msg-is-pruned) + (rmail-maybe-set-message-counters, rmail-msgbeg, rmail-msgend) + (rmail-toggle-header): + * mail/sendmail.el (dired-view-file, dired-get-filename): + * mail/rmailkwd.el (rmail-maybe-set-message-counters) + (rmail-display-labels, rmail-msgbeg) + (rmail-set-message-deleted-p, rmail-message-labels-p) + (rmail-show-message, mail-comma-list-regexp) + (mail-parse-comma-list): + * mail/rmail.el (rmail-spam-filter, rmail-summary-goto-msg) + (rmail-summary-mark-undeleted, rmail-summary-mark-deleted) + (rfc822-addresses, mail-abbrev-make-syntax-table) + (mail-sendmail-delimit-header, mail-header-end): + * mail/hashcash.el (message-narrow-to-headers-or-head) + (message-fetch-field, message-goto-eoh) + (message-narrow-to-headers): + * vc.el (view-mode-exit): Declare as functions. + + * mail/vms-pmail.el: + * vmsproc.el: + * vms-patch.el: Don't byte compile these files, they don't work. + +2007-11-27 Glenn Morris <rgm@gnu.org> + + * calc/calc-ext.el (math-read-big-rec): + * calc/calc-nlfit.el (math-map-binop): + * calc/calc.el (math-normalize-nonstandard): Fix declarations. + + * eshell/eshell.el (eshell-report-bug): Add version number of + obsolescence. + + * emulation/viper.el, emulation/viper-util.el, + emulation/viper-macs.el, emulation/viper-keym.el, + emulation/viper-ex.el, emulation/viper-cmd.el: + Load viper-*.el files silently. + + * ediff-diff.el, ediff-help.el, ediff-merg.el, ediff-mult.el, + ediff-ptch.el, ediff-util.el, ediff-vers.el, ediff-wind.el, ediff.el: + Load ediff-*.el files silently. + + * ediff.el: Load dired silently. Don't load info, pcl-cvs when + compiling. + (Info-goto-node): Declare as a function. + + * ediff-init.el: Don't load ange-ftp when compiling. + * ediff-util.el: Don't load reporter when compiling. + + * ediff-wind.el (ediff-display-pixel-width) + (ediff-display-pixel-height): + * generic-x.el (ini-generic-mode): + * ps-print.el (ps-mule-encode-header-string, ps-mule-begin-page) + (ps-mule-prepare-ascii-font, ps-mule-set-ascii-font) + (ps-mule-initialize, ps-mule-begin-job): + * calendar/cal-bahai.el (add-to-diary-list, diary-name-pattern) + (mark-calendar-days-named): + * calendar/cal-hebrew.el (holiday-filter-visible-calendar) + (add-to-diary-list, diary-name-pattern) + (mark-calendar-days-named): + * calendar/cal-islam.el (add-to-diary-list, diary-name-pattern) + (mark-calendar-days-named): + * calendar/cal-x.el (make-fancy-diary-buffer): + * calendar/holidays.el (calendar-absolute-from-julian): + * calendar/todo-mode.el (calendar-current-date): + * calendar/cal-menu.el (calendar-increment-month) + (calendar-month-name, extract-calendar-year) + (calendar-cursor-to-date, holiday-list, calendar-sunrise-sunset) + (calendar-current-date, calendar-cursor-holidays) + (calendar-date-string, insert-diary-entry, calendar-set-mark) + (cal-tex-cursor-day, cal-tex-cursor-week, cal-tex-cursor-week2) + (cal-tex-cursor-week-iso, cal-tex-cursor-week-monday) + (cal-tex-cursor-filofax-daily, cal-tex-cursor-filofax-2week) + (cal-tex-cursor-filofax-week, cal-tex-cursor-month) + (cal-tex-cursor-month-landscape, cal-tex-cursor-year) + (cal-tex-cursor-filofax-year, cal-tex-cursor-year-landscape) + (calendar-day-of-year-string, calendar-iso-date-string) + (calendar-julian-date-string, calendar-astro-date-string) + (calendar-absolute-from-gregorian, calendar-hebrew-date-string) + (calendar-persian-date-string, calendar-bahai-date-string) + (calendar-islamic-date-string, calendar-chinese-date-string) + (calendar-coptic-date-string, calendar-ethiopic-date-string) + (calendar-french-date-string, calendar-mayan-date-string) + (calendar-print-chinese-date, calendar-goto-date): + Declare as functions. + + * calendar/calendar.el (nongregorian-diary-listing-hook): Doc fix. + (Info-find-emacs-command-nodes, Info-find-node): Declare as functions. + + * ffap.el (ffap-bug, ffap-submit-bug): Redefine as obsolete + aliases for report-emacs-bug. + (gnus-summary-select-article, gnus-configure-windows): Declare as + functions. + + * pgg-parse.el (pgg-parse-24, pgg-parse-crc24-string): Declare for + compiler. + + * pgg.el (pgg-clear-string): Declare as a function. + (pgg-run-at-time-1): Wrap whole definition in (featurep 'xemacs) test. + (pgg-run-at-time, pgg-cancel-timer): Move definitions before use. + + * emacs-lisp/check-declare.el (check-declare-locate): + Handle compressed files. + (check-declare-verify): Handle define-generic-mode, + define-global(ized)-minor-mode, define-obsolete-function-alias. + +2007-11-27 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-menu.el (calc-modes-menu): Add normal and incomplete + algebraic modes. + + * calc/calc-aent.el (calc-refresh-evaltos, calc-execute-kbd-macro) + (math-is-true, calc-explain-why, calc-alg-edit) + (math-composite-inequalities, math-flatten-lands) + (math-multi-subst, calcFunc-vmatches, math-simplify) + (math-known-matrixp, math-parse-fortran-subscr, math-to-radians-2) + (math-read-string, math-read-brackets, math-read-angle-brackets): + Declare as functions. + + * calc/calcalg3.el (calc-fit-s-shaped-logistic-curve) + (calc-fit-bell-shaped-logistic-curve) + (calc-fit-hubbert-linear-curve, calc-graph-add-curve) + (calc-graph-lookup, calc-graph-set-styles, math-min-list) + (math-max-list): Declare as functions. + (math-map-binop): New function. + (calc-curve-fit): Replace `mapcar*' by `math-map-binop'. + + * calc/calc.el (calc-set-language, calc-edit-finish) + (calc-edit-cancel, calc-do-quick-calc, calc-do-calc-eval) + (calc-do-keypad, calcFunc-unixtime, math-parse-date) + (math-lessp, calc-embedded-finish-command) + (calc-embedded-select-buffer, calc-embedded-mode-line-change) + (calc-push-list-in-macro, calc-replace-selections) + (calc-record-list, calc-normalize-fancy, calc-do-handle-whys) + (calc-top-selected, calc-sel-error, calc-pop-stack-in-macro) + (calc-embedded-stack-change, calc-refresh-evaltos) + (calc-do-refresh, calc-binary-op-fancy, calc-unary-op-fancy) + (calc-delete-selection, calc-alg-digit-entry, calc-alg-entry) + (calc-dots, calc-temp-minibuffer-message, math-read-radix-digit) + (calc-digit-dots, math-normalize-fancy, math-normalize-nonstandard) + (math-recompile-eval-rules, math-apply-rewrites, calc-record-why) + (math-dimension-error, calc-incomplete-error, math-float-fancy) + (math-neg-fancy, math-zerop, calc-add-fractions) + (math-add-objects-fancy, math-add-symb-fancy, math-mul-zero) + (calc-mul-fractions, math-mul-objects-fancy, math-mul-symb-fancy) + (math-reject-arg, math-div-by-zero, math-div-zero, math-make-frac) + (calc-div-fractions, math-div-objects-fancy, math-div-symb-fancy) + (math-compose-expr, math-comp-width, math-composition-to-string) + (math-stack-value-offset-fancy, math-format-flat-expr-fancy) + (math-adjust-fraction, math-format-binary, math-format-radix) + (math-group-float, math-mod, math-format-number-fancy) + (math-format-bignum-fancy, math-read-number-fancy) + (calc-do-grab-region, calc-do-grab-rectangle, calc-do-embedded) + (calc-do-embedded-activate, math-do-defmath) + (calc-load-everything): Declare as functions. + + * calc/calc-ext.el (math-clip, math-round, math-simplify) + (math-simplify-extended, math-simplify-units, calc-set-language) + (calc-flush-caches, calc-save-modes, calc-embedded-modes-change) + (calc-embedded-var-change, math-mul-float, math-arctan-raw) + (math-sqrt-float, math-exp-minus-1-raw, math-normalize-polar) + (math-normalize-hms, math-normalize-mod, math-make-sdev) + (math-make-intv, math-normalize-logical-op, math-possible-signs) + (math-infinite-dir, math-calcFunc-to-var) + (calc-embedded-evaluate-expr, math-known-nonzerop) + (math-read-expr-level, math-read-big-rec, math-read-big-balance) + (math-format-date, math-vector-is-string, math-vector-to-string) + (math-format-radix-float, math-compose-expr, math-abs) + (math-format-bignum-binary, math-format-bignum-octal) + (math-format-bignum-hex, math-format-bignum-radix) + (math-compute-max-digits): Declare as functions. + (math-provably-realp): Fix typo. + + * calc/calc-forms.el (calendar-current-time-zone) + (calendar-absolute-from-gregorian, dst-in-effect): Declare as + functions. + + * calc/calc-help.el (Info-goto-node, Info-last): Declare as functions. + + * calc/calc-lang.el (math-read-factor, math-read-expr-level): + Declare as functions. + + * calc/calc-macs.el (math-zerop, math-negp, math-looks-negp) + (math-posp, math-compare, math-bignum, math-compare-bignum): + Declare as functions. + + * calc/calc-misc.el (calc-do-keypad, calc-inv-hyp-prefix-help) + (calc-inverse-prefix-help, calc-hyperbolic-prefix-help) + (calc-explain-why, calc-clear-command-flag) + (calc-roll-down-with-selections, calc-roll-up-with-selections) + (calc-last-args, calc-is-inverse, calc-do-prefix-help) + (math-objvecp, math-known-scalarp, math-vectorp, math-matrixp) + (math-trunc-special, math-trunc-fancy, math-floor-special) + (math-floor-fancy, math-square-matrixp, math-matrix-inv-raw) + (math-known-matrixp, math-mod-fancy, math-pow-of-zero) + (math-pow-zero, math-pow-fancy): Declare as functions. + + * calc/calc-mode.el (calc-embedded-save-original-modes): + Declare as a function. + + * calc/calc-nlfit.el (calc-get-fit-variables, math-map-binop): + Declare as functions. + (math-nlfit-make-matrix, math-nlfit-find-qmax, math-nlfit-fit) + (math-nlfit-fit-curve, calc-fit-hubbert-linear-curve): + Replace `mapcar*' by `math-map-binop'. + (math-nlfit-make-matrix): Replace `copy-list' with `copy-sequence'. + + * calc/calc-prog.el (edmacro-format-keys,edmacro-parse-keys) + (math-read-expr-level): Declare as functions. + + * calc/calc-vec.el (math-read-expr-level): Declare as a function. + +2007-11-26 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/lisp.el (end-of-defun): Restructure so that + end-of-defun-function is called consistently, even for negative + arguments. + (end-of-defun-function): Default to forward-sexp. + +2007-11-26 Juanma Barranquero <lekktu@gmail.com> + + * emacs-lisp/bytecomp.el (batch-byte-recompile-directory): Doc fix. + +2007-11-26 Glenn Morris <rgm@gnu.org> + + * calendar/cal-menu.el (cal-menu-holidays-menu): Use :label rather + than :suffix. + + * emacs-lisp/easymenu.el (easy-menu-define): Doc fix. + +2007-11-26 Simon Josefsson <simon@josefsson.org> + + * net/imap.el: Move from ../gnus. + +2007-11-25 Reiner Steib <Reiner.Steib@gmx.de> + + * doc-view.el (doc-view-mode-p): New function. + +2007-11-25 Dan Nicolaescu <dann@ics.uci.edu> + + * mail/mspools.el (rmail-get-new-mail): + * mail/reporter.el (mail-position-on-field, mail-text): + * mail/rmail.el (mail-position-on-field, mail-text-start) + (rmail-update-summary): + * mail/rmailedit.el (rmail-summary-disable, rmail-summary-enable): + * mail/rmailmsc.el (rmail-parse-file-inboxes, rmail-show-message): + * mail/rmailout.el (rmail-update-summary): + * mail/rmailsort.el (rmail-update-summary): + * mail/sendmail.el (dired-move-to-filename, dired-get-filename) + (dired-view-file): + * mail/uce.el (mail-strip-quoted-names): + * mail/undigest.el (rmail-update-summary): + * mail/unrmail.el (mail-strip-quoted-names): + * ediff.el (diff-latest-backup-file): Declare as functions. + + * obsolete/mlsupport.el (ml-previous-page): Fix typo. + (kill-to-end-of-line): + * obsolete/rnews.el (news-set-minor-modes): + Remove non working functions. + +2007-11-25 Glenn Morris <rgm@gnu.org> + + * eshell/esh-maint.el (top-level): Use require with NOERROR for + pcomplete. Don't mess with load-path. + + * eshell/eshell.el (eshell-report-bug-address): Remove. + (eshell-report-bug): Redefine as an alias for report-emacs-bug. + +2007-11-24 Glenn Morris <rgm@gnu.org> + + * calendar/appt.el: Remove leading `*' from defcustom doc-strings. + (appt-disp-window): Don't require electric. + Simplify minibuffer-avoidance code. + (appt-select-lowest-window): Avoid minibuffer. + + * eshell/eshell.el: Remove leading `*' from defcustom doc-strings. + (esh-mode): Require it. + (esh-util): Use require rather than featurep and load. + (eshell): No need to test if eshell-mode is bound; remove obsolete + reference to eshell-auto. + (eshell-command, eshell-command-result): Don't require esh-mode + now that the file does. + (top-level): Move provide statement to the end of the file. + Re-order and update commentary. + +2007-11-24 Thien-Thi Nguyen <ttn@gnuvola.org> + + * vc.el (vc-annotate-mode): Frob buffer invisibility spec. + (vc-annotate-toggle-annotation-visibility): New command. + (vc-annotate-mode-map): Bind "V" to it. + (vc-annotate-mode-menu): Add entry for it. + (vc-annotate-get-time-set-line-props): New func. + (vc-annotate-display-autoscale) + (vc-annotate-display-difference): Use it. + + * vc-git.el (vc-git-annotate-time): Handle optional field FILENAME. + Also, match one space at end of annotation text, after last paren. + +2007-11-24 Michael Albinus <michael.albinus@gmx.de> + + * ido.el (ido-file-name-all-completions-1): Check for fboundp of + `tramp-completion-mode-p' as it is in Tramp 2.1. Let-bind + `tramp-completion-mode'. + +2007-11-24 Thien-Thi Nguyen <ttn@gnuvola.org> + + * vc-git.el (vc-git-show-log-entry): New func. + + * vc-git.el (vc-git--call, vc-git--out-ok): New funcs. + (vc-git-state): Use vc-git--call. + (vc-git-registered, vc-git-working-revision) + (vc-git-previous-revision, vc-git-next-revision) + (vc-git--run-command-string, vc-git-symbolic-commit): + Use vc-git--out-ok. + +2007-11-24 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/byte-run.el (declare-function): Doc fix. + +2007-11-24 Kenichi Handa <handa@m17n.org> + + * international/ucs-tables.el (ucs-8859-7-alist): Update the table. + +2007-11-23 David Kastrup <dak@gnu.org> + + * server.el (server-process-filter): Use `command-line-args-left'. + +2007-11-23 Stefan Monnier <monnier@iro.umontreal.ca> + + * nxml/subdirs.el, nxml/char-data/subdirs.el, nxml/rng-auto.el: Remove. + +2007-11-23 Dan Nicolaescu <dann@ics.uci.edu> + + * vc.el (vc-deduce-fileset): Also look for a fileset in the parent + buffer if the parent buffer is in vc-dired-mode. + +2007-11-23 Mark A. Hershberger <mah@everybody.org> + + * nxml: Initial merge of nxml. Kept nxml/char-name subdir for now. + +2007-11-23 Juri Linkov <juri@jurta.org> + + * dired.el (dired-read-dir-and-switches): For C-x d, set the + value for M-n to the visited file name of the current buffer. + Use minibuffer-with-setup-hook to set minibuffer-default to + buffer-file-name inside read-file-name. + + * man.el (Man-getpage-in-background): Don't disregard user option + `Man-width' on non-window systems. Remove test for `window-system' + around setting envvar "COLUMNS" depending on the value of `Man-width'. + + * progmodes/grep.el (grep-process-setup): Set envvar "TERM" to + "emacs-grep". Set envvar "GREP_OPTIONS" to "--color=auto" instead + of "--color=always". + +2007-11-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/lisp.el (beginning-of-defun-raw): Pass `arg' down to + beginning-of-defun-function. + +2007-11-22 Reiner Steib <Reiner.Steib@gmx.de> + + * mail/hashcash.el: Move from ../gnus. Add hashcash payments to email. + +2007-11-22 Glenn Morris <rgm@gnu.org> + + * emulation/cua-base.el (x-clipboard-yank): Fix declaration. + + * emacs-lisp/check-declare.el (check-declare-locate): New function. + (check-declare-scan): Use check-declare-locate. + (check-declare-verify): No longer adjust fnfile, now + check-declare-locate does it. + + * emacs-lisp/byte-run.el (declare-function): Doc fix. + +2007-11-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * subr.el (posn-col-row): Make the `default-value' use explicit. + + * window.el (balance-windows): Remove unused var `counter'. + (bw-balance-sub): Remove unused var `lastchild'. + (split-window-vertically): Remove unused var `switch'. + (recenter-top-bottom): Remove unused vars `bottom', `current', `total'. + + * emacs-lisp/bytecomp.el + (byte-compile-file-form-custom-declare-variable): Simplify. + +2007-11-22 Juanma Barranquero <lekktu@gmail.com> + + * cus-edit.el (custom-mode): Define with `define-derived-mode'. + Set `show-trailing-whitespace' to nil. + + * dired.el (make-symbolic-link): + * dired-aux.el (mailcap-parse-mailcaps, mailcap-parse-mimetypes) + (mailcap-extension-to-mime, mailcap-mime-info, make-symbolic-link): + * dired-x.el (make-symbolic-link): + * frame.el (x-initialize-window-system): + * menu-bar.el (x-menu-bar-open): + * select.el (x-get-cut-buffer-internal, x-rotate-cut-buffers-internal) + (x-store-cut-buffer-internal): + * wdired.el (make-symbolic-link): + * x-dnd.el (x-register-dnd-atom, x-get-atom-name) + (x-send-client-message): + * emulation/cua-base.el (x-clipboard-yank): Declare as functions. + +2007-11-22 Jan Dj,Ad(Brv <jan.h.d@swipnet.se> + + * term/x-win.el (x-gtk-map-stock): Check if FILE is a string. + +2007-11-22 Glenn Morris <rgm@gnu.org> + + * dos-fns.el (int86): + * term/mac-win.el (mac-font-panel-mode): Fix declarations. + + * calendar/cal-menu.el (cal-menu-holidays-menu): Fix holiday-list call. + + * calendar/holidays.el (holiday-list): Add autoload cookie. + + * emacs-lisp/check-declare.el (check-declare-scan): Expand .c + files relative to src/ directory. + (check-declare-verify): Handle .c files. Warn if could not find + an arglist to check. + + * emacs-lisp/byte-run.el (declare-function): Doc fix. + +2007-11-22 Dan Nicolaescu <dann@ics.uci.edu> + + * replace.el (occur-mode-map): Add a major mode menu with entries + for all occur operations. + + * international/titdic-cnv.el (dos-8+3-filename): + * obsolete/fast-lock.el (msdos-long-file-names): + * frame.el (msdos-mouse-p): + * files.el (msdos-long-file-names, w32-long-file-name): + * term/mac-win.el (mac-code-convert-string, mac-coerce-ae-data) + (mac-resume-apple-event, mac-font-panel-mode) + (mac-atsu-font-face-attributes, mac-ae-set-reply-parameter) + (mac-clear-font-name-table): + * term/pc-win.el (msdos-remember-default-colors) + (w16-set-clipboard-data, w16-get-clipboard-data): + * term/w32-win.el (w32-send-sys-command, w32-select-font) + (set-message-beep): + * net/browse-url.el (w32-shell-execute): + * w32-fns.el (set-message-beep, w32-get-clipboard-data) + (w32-get-locale-info, w32-get-valid-locale-ids) + (w32-set-clipboard-data): + * dos-fns.el (int86, msdos-long-file-names): + * dos-w32.el (default-printer-name): Declare as functions. + +2007-11-21 Jason Rumney <jasonr@gnu.org> + + * emacs-lisp/byte-run.el (declare-function): Return nil. + +2007-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/sh-script.el (sh-mode): Set defun-prompt-regexp. + +2007-11-21 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el (ps-lpr-switches): Docstring fix. + (ps-string-list): New fun. + (ps-do-despool): Code fix. + +2007-11-21 Juanma Barranquero <lekktu@gmail.com> + + * w32-fns.el: Undo 2007-11-21 change by Dan Nicolaescu. + +2007-11-21 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/check-declare.el (check-declare-verify): Skip C files + for now. Handle define-minor-mode, and defalias (with no argument + checking). + +2007-11-21 Dan Nicolaescu <dann@ics.uci.edu> + + * frame.el (msdos-mouse-p): + * files.el (msdos-long-file-names, w32-long-file-name): + * term/mac-win.el (mac-code-convert-string, mac-coerce-ae-data) + (mac-resume-apple-event, mac-font-panel-mode) + (mac-atsu-font-face-attributes, mac-ae-set-reply-parameter) + (mac-clear-font-name-table): + * term/pc-win.el (msdos-remember-default-colors) + (w16-set-clipboard-data, w16-get-clipboard-data): + * term/w32-win.el (w32-send-sys-command, w32-select-font) + (set-message-beep): + * net/browse-url.el (w32-shell-execute): + * dos-fns.el (int86, msdos-long-file-names): + * dos-w32.el (default-printer-name): Undo previous change. + +2007-11-21 Eli Zaretskii <eliz@gnu.org> + + * international/mule-cmds.el (set-locale-environment): + Set default-file-name-coding-system _after_ keyboard and terminal + coding systems. This fixes last change. + + * mail/rmail.el (rmail-current-subject-regexp): Allow more than + one space after "Subject:". + +2007-11-21 Stefan Monnier <monnier@iro.umontreal.ca> + + * pcvs-parse.el (cvs-parse-table): Ignore errors when looking up files + in order to determine if there's a conflict. + +2007-11-21 Richard Stallman <rms@gnu.org> + + * bindings.el (esc-map): Bind C-M-l here; moved from reposition.el. + + * reposition.el (reposition-window): + Binding C-M-l moved to bindings.el. + + * bindings.el (ctl-x-4-map): Bind C-x 4 a here; moved from add-log.el. + + * add-log.el (add-change-log-entry-other-window): + Key binding C-x 4 a moved to bindings.el. + + * bindings.el (minibuffer-local-map): Bind C-tab here; moved + from filecache.el. + + * filecache.el: Minibuffer map bindings moved to bindings.el. + +2007-11-21 Jason Rumney <jasonr@gnu.org> + + * international/mule-cmds.el (set-locale-environment): + Set default-file-name-coding-system from system defaults on Windows. + +2007-11-21 Jason Rumney <jasonr@gnu.org> + + * term/w32console.el: New term init file for w32 console. + + * w32-fns.el (x-alternatives-map): Copy from term/x-win.el. + (x-setup-function-keys): Likewise, replacing top-level key definitions. + (w32-tty-standard-colors): Move to term/w32console.el. + + * term/w32-win.el (x-setup-function-keys): Remove. + + * term/tty-colors.el (tty-register-default-colors): Remove special + case for w32. + +2007-11-21 Dan Nicolaescu <dann@ics.uci.edu> + + * frame.el (msdos-mouse-p): + * generic-x.el (w32-shell-name): + * files.el (msdos-long-file-names, w32-long-file-name) + (dired-get-filename, dired-unmark, dired-do-flagged-delete) + (dos-8+3-filename, vms-read-directory, view-mode-disable): + * term/mac-win.el (mac-code-convert-string, mac-coerce-ae-data) + (mac-resume-apple-event, mac-font-panel-mode) + (mac-atsu-font-face-attributes, mac-ae-set-reply-parameter) + (mac-clear-font-name-table): + * term/pc-win.el (msdos-remember-default-colors) + (w16-set-clipboard-data, w16-get-clipboard-data): + * term/w32-win.el (w32-send-sys-command, w32-select-font) + (set-message-beep): + * w32-fns.el (set-message-beep, w32-get-clipboard-data) + (w32-get-locale-info, w32-get-valid-locale-ids) + (w32-set-clipboard-data): + * help-fns.el (ad-get-advice-info): + * font-lock.el (fast-lock-after-fontify-buffer) + (fast-lock-after-unfontify-buffer, fast-lock-mode) + (lazy-lock-after-fontify-buffer) + (lazy-lock-after-unfontify-buffer, lazy-lock-mode): + * net/browse-url.el (w32-shell-execute): + * dos-fns.el (int86, msdos-long-file-names): + * dos-w32.el (default-printer-name): Declare as functions. + +2007-11-21 Juanma Barranquero <lekktu@gmail.com> + + * textmodes/paragraphs.el (forward-sentence): Doc fix. + Reported by Drew Adams <drew.adams@oracle.com>. + +2007-11-20 Jason Rumney <jasonr@gnu.org> + + * term/w32-win.el (x-setup-function-keys): Protect against + multiple calls on the same terminal. + +2007-11-20 Dan Nicolaescu <dann@ics.uci.edu> + + * term/mac-win.el (x-setup-function-keys): Only setup + local-function-key-map if it has not been setup already for the + current frame. Move the suspend-emacs processing here. + +2007-11-20 Juanma Barranquero <lekktu@gmail.com> + + * progmodes/grep.el (xargs-program): New variable. + (grep-compute-defaults): Use it. + (grep-default-command): Doc fix. + (grep, lgrep, rgrep): Reflow docstrings. + +2007-11-20 Dan Nicolaescu <dann@ics.uci.edu> + + * vc.el (vc-find-revision): Set the parent buffer. + Use when instead of if. + + * progmodes/python.el (info-lookup-maybe-add-help): + * progmodes/ps-mode.el (doc-view-minor-mode): + * mail/emacsbug.el (Info-menu, Info-goto-node): + * emulation/viper-keym.el (viper-ex) + (viper-normalize-minor-mode-map-alist, viper-set-mode-vars-for): + * emulation/viper-cmd.el (widget-type, widget-button-press) + (viper-set-hooks): + * emacs-lisp/tcover-unsafep.el (unsafep-function): + * emacs-lisp/tcover-ses.el (ses-set-curcell, ses-update-cells) + (ses-load, ses-vector-delete, ses-create-header-string) + (ses-read-cell, ses-read-symbol, ses-command-hook, ses-jump): + * emacs-lisp/gulp.el (mail-subject, mail-send): Declare as functions. + +2007-11-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * pcvs.el (cvs-revert-if-needed): Fix copy&paste typo. + +2007-11-20 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/check-declare.el (check-declare-verify): Tweak regexp + for end of function-name. Handle define-derived-mode. + +2007-11-20 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/idlw-help.el: Require browse-url unconditionally, it + is available by default. + (idlwave-help-browse-url-available): Change default to t. + + * emulation/edt.el (defgroup, defcustom): Remove definition. + (eval-when-compile): Remove. + (c-mark-function): + * textmodes/reftex-dcr.el (bibtex-beginning-of-entry): + * textmodes/fill.el (comment-search-forward) + (comment-string-strip): + * progmodes/prolog.el (comint-mode, comint-send-string) + (comint-send-region, comint-send-eof): + * progmodes/dcl-mode.el (imenu-default-create-index-function): + * emulation/viper-util.el (viper-forward-Word): + * emulation/vi.el (c-mark-function): + * emulation/edt-vt100.el (vt100-wide-mode): + * emacs-lisp/timer.el (diary-entry-time): Declare as functions. + +2007-11-19 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-open-connection-setup-interactive-shell): + Still some tuning in case of an echoing shell. + (tramp-send-command): Connection property "remote-echo" is not + persistent; cache key is the process therefore. + +2007-11-19 Juanma Barranquero <lekktu@gmail.com> + + * replace.el (map-query-replace-regexp): Doc fix (revert part of + 2000-05-21T17:04:47Z!fx@gnu.org made on 2000-05-21 with no ChangeLog entry). + +2007-11-19 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/octave-mod.el (inferior-octave-send-list-and-digest): + * play/yow.el (doctor-ret-or-read): + * vc-hooks.el (vc-dired-resynch-file): + * vc-hg.el (log-view-get-marked): + * smerge-mode.el (ediff-cleanup-mess): + * pcvs.el (vc-editable-p, vc-checkout): + * pcomplete.el (comint-bol): + * informat.el (texinfo-format-refill): + * ido.el (tramp-tramp-file-p): + * ibuffer.el (ibuffer-mark-on-buffer, ibuffer-format-qualifier) + (ibuffer-generate-filter-groups, ibuffer-format-filter-group-data): + * add-log.el (c-beginning-of-defun, c-end-of-defun): Declare as + functions. + + * textmodes/ispell.el (ispell-int-char): Make it a defalias + instead of fset. + (ispell-message): Use with-no-warnings for sc-cite-regexp call. + + * ido.el (ido-file-internal): Move with-no-warnings to include the + ffap-string-at-point call. + + * pcomplete.el (pcomplete-executables): Move defsubst before first use. + + * vc-hg.el (vc-hg-revision-table): Fix last change. + +2007-11-19 Martin Rudalics <rudalics@gmx.at> + + * menu-bar.el (top-level): Deactivate clipboard-kill-region and + clipboard-yank when the buffer is read-only. + + * cus-edit.el (custom-field-keymap): Move to other Custom mode + keymaps such that it's before the definition of Custom-mode-menu. + (Custom-mode-menu): Show it for custom-field-keymap too. + +2007-11-19 Nick Roberts <nickrob@snap.net.nz> + + * progmodes/gdb-ui.el: Update commentary. + +2007-11-18 Dan Nicolaescu <dann@ics.uci.edu> + + * net/tramp.el (tramp-terminal-type): Remove duplicated definition. + +2007-11-19 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/check-declare.el (check-declare-verify): If fnfile + does not exist, try adding `.el' extension. Also search for defsubsts. + + * cus-edit.el (recentf-expand-file-name): + * dired.el (dired-relist-entry): + * subr.el (w32-shell-dos-semantics): + * emacs-lisp/bytecomp.el (compilation-forget-errors): + Declare as functions. + +2007-11-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * abbrev.el (kill-all-abbrevs, insert-abbrevs) + (prepare-abbrev-list-buffer): Use dolist. + (clear-abbrev-table): Preserve properties. + +2007-11-18 Shigeru Fukaya <shigeru.fukaya@gmail.com> (tiny change) + + * textmodes/texinfmt.el (texinfo-format-printindex): + Collect combined indexes using texinfo-short-index-format-cmds-alist. + Reported on <bug-texinfo@gnu.org>. + +2007-11-18 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-completion-reread-directory-timeout): + New defcustom. + (tramp-handle-file-name-all-completions): Flush directory contents + from cache regularly. + (tramp-set-auto-save-file-modes): Check also for `buffer-modified-p'. + (tramp-open-connection-setup-interactive-shell): + Call `tramp-cleanup-connection' via funcall. + + * net/tramp-ftp.el (tramp-ftp-file-name-handler): Temp file is already + created when copying. + +2007-11-17 Dan Nicolaescu <dann@ics.uci.edu> + + * eshell/esh-util.el (eshell-under-xemacs-p): Remove. + * eshell/esh-mode.el (eshell-mode-syntax-table, command-running-p): + * eshell/esh-ext.el (eshell-external-command): + * eshell/esh-cmd.el (require): + * eshell/em-unix.el (eshell-plain-locate-behavior): + * eshell/em-cmpl.el (eshell-cmpl-initialize): + Replace eshell-under-xemacs-p with (featurep 'xemacs). + * eshell/esh-mode.el (characterp, char-int): Remove unused + conditional defaliases. + + * pcomplete.el (pcomplete-event-matches-key-specifier-p): + Rename from event-matches-key-specifier-p, define unconditionally. + (event-basic-type): Remove unused defalias. + (pcomplete-show-completions): + Use pcomplete-event-matches-key-specifier-p. + +2007-11-17 Eli Zaretskii <eliz@gnu.org> + + * eshell/esh-module.el (eshell-load-defgroups): Don't make backups + when saving esh-groups.el. + +2007-11-17 Martin Rudalics <rudalics@gmx.at> + + * wid-edit.el (widget-default-complete): + * progmodes/flymake.el (flymake-goto-file-and-line): + Fix typo in (doc-)string. + +2007-11-17 Glenn Morris <rgm@gnu.org> + + * emacs-lisp/byte-run.el (declare-function): New macro. + * emacs-lisp/bytecomp.el (byte-compile-declare-function): + New function, byte-hunk-handler for declare-function. + (byte-compile-callargs-warn): Handle declared functions. + + * emacs-lisp/check-declare.el: New file. + * Makefile.in (check-declare): New target. + + * progmodes/fortran.el (gud-find-c-expr): Declare as a function. + + * subr.el (process-lines): Move here from ../admin/admin.el. + * emacs-lisp/authors.el (authors-process-lines): Remove. + (authors): Use process-lines rather than authors-process-lines. + + * progmodes/compilation-perl.el, progmodes/compilation-weblint.el: + Remove these files. + +2007-11-17 Juanma Barranquero <lekktu@gmail.com> + + * emacs-lisp/backquote.el (backquote): + Improve argument/docstring consistency. + + * emacs-lisp/ring.el (ring-size, ring-p, ring-insert) + (ring-length, ring-empty-p): Use c[ad]dr. + (ring-plus1): Use `1+'. + (ring-minus1): Use `zerop'. + (ring-remove): Use c[ad]dr. Use `when'. + (ring-copy): Use c[ad]dr. Use `let', not `let*'. + (ring-ref): Use `let', not `let*'. + (ring-insert-at-beginning): Use c[ad]dr. Doc fix. + (ring-insert+extend): Use c[ad]dr. Fix typo in docstring. + (ring-member): Simplify. Doc fix. + (ring-convert-sequence-to-ring): Simplify. + +2007-11-17 Juri Linkov <juri@jurta.org> + + * dired-aux.el (dired-create-directory): Allow creating + a directory of an arbitrary depth. Add a loop to find the topmost + nonexistent parent dir `new', and call `dired-add-file' on it. + Set the `PARENTS' arg of `make-directory' to t. + +2007-11-16 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-aent.el (calc-last-user-lang-parse-table): New variable. + (math-build-parse-table): Get parse information from math-parse-table. + +2007-11-16 Stefan Monnier <monnier@iro.umontreal.ca> + + * window.el (recenter-last-op): New var. + (recenter-top-bottom): New command. + (global-map): Bind it to C-l. + + * abbrev.el (abbrev--write): Fix error in transcription from C. + + * emulation/pc-select.el (pc-select-shifted-mark): Remove. + (pc-select-ensure-mark): Set mark-active to a special value instead. + Rename from ensure-mark. Update call callers. + (pc-select-maybe-deactivate-mark): Rename from maybe-deactivate-mark. + Rewrite. Update all callers. + (pc-selection-mode): Remove redundant var declaration. + +2007-11-16 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el (doc-view-search-backward, doc-view-search): + Fix assignment to free variable bug. + +2007-11-16 Martin Pohlack <mp26@os.inf.tu-dresden.de> (tiny change) + + * emulation/pc-select.el (pc-select-shifted-mark): New var. + (ensure-mark): Set it. + (maybe-deactivate-mark): New fun. + Use it everywhere instead of (setq mark-active nil). + +2007-11-16 Dan Nicolaescu <dann@ics.uci.edu> + + * textmodes/reftex-dcr.el (reftex-start-itimer-once): + Add check for XEmacs. + + * calc/calc-menu.el (calc-mode-map): Pacify byte compiler. + + * doc-view.el (doc-view-resolution): Add missing :group. + +2007-11-16 Juanma Barranquero <lekktu@gmail.com> + + * subr.el (make-variable-frame-local): + Fix typo in obsolescence declaration. + +2007-11-16 Werner Lemberg <wl@gnu.org> + + * files.el (set-auto-mode-1): Check second line for -*- if file + starts with '\" (which is used by man pages to identify needed + troff preprocessors). + +2007-11-16 Glenn Morris <rgm@gnu.org> + + * mail/mail-extr.el (mail-extr-all-top-level-domains): Update domains. + +2007-11-16 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-lang.el (math-oper-table): Fix typo. + Reduce precedence of "/" for TeX. + + * calc/calc-menu.el (calc-modes-menu): Add Languages submenu. + +2007-11-16 Juri Linkov <juri@jurta.org> + + * dired-aux.el (dired-read-shell-command-default): New function. + (dired-read-shell-command): Use its return value for DEFAULT arg. + + * replace.el (keep-lines-read-args, occur-read-primary-args): + Use a list of default values for DEFAULT arg of read-from-minibuffer. + + * man.el (Man-heading-regexp): Add 0-9. + (Man-first-heading-regexp): Remove leading space [ \t]* before NAME. + +2007-11-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * doc-view.el (doc-view-ghostscript-options): Remove resolution arg. + (doc-view-resolution): New custom var. + (doc-view-pdf/ps->png): Use it. + (doc-view-shrink-factor): New var. + (doc-view-enlarge, doc-view-shrink): New commands. + (doc-view-mode-map): Use them. + +2007-11-15 Juanma Barranquero <lekktu@gmail.com> + + * ediff-wind.el (ediff-window-setup-function): + * simple.el (normal-erase-is-backspace): + * eshell/em-unix.el (eshell/info): + * progmodes/cc-engine.el (c-crosses-statement-barrier-p): + Fix typos in docstrings. + + * emulation/cua-base.el (cua--keymaps-initialized): + Rename from `cua--keymaps-initalized'. Callers changed. + (cua-highlight-region-shift-only): Doc fix. + (cua-paste-pop): Fix typo in docstring. + +2007-11-15 Stefan Monnier <monnier@iro.umontreal.ca> + + * emulation/cua-base.el (cua--pre-command-handler-1): + Use input-decode-map instead of function-key-map. + Use event-modifiers now that it works reliably. + + * vc.el (vc-diff-internal): Pop-to-buffer later. + + * subr.el (event-modifiers): Use internal-event-symbol-parse-modifiers. + + * pcvs.el (cvs-revert-if-needed): Ignore `unknown' files, since cvs + did not touch them. + +2007-11-15 Jay Belanger <jay.p.belanger@gmail.com> + + * calc/calc-menu.el: New file. + * calc/calc.el (calc-mode): Require calc-menu. + +2007-11-14 Juanma Barranquero <lekktu@gmail.com> + + * isearch-multi.el (isearch-buffers-next-buffer-function): Doc fix. + +2007-11-14 Nick Roberts <nickrob@snap.net.nz> + + * progmodes/gdb-ui.el (gdb-parent-bptno-enabled): New variable. + (gdb-breakpoint-regexp, gdb-mouse-toggle-breakpoint-margin) + (gdb-mouse-toggle-breakpoint-fringe, gdb-delete-breakpoint) + (gdb-goto-breakpoint): Generalise for breakpoints with multiple + locations. + (gdb-info-breakpoints-custom, gdb-assembler-custom) + (gdb-toggle-breakpoint): Update for new gdb-breakpoint-regexp. + (gdb-put-breakpoint-icon): Only display icon for parent breakpoint. + +2007-11-13 Noah Friedman <friedman@splode.com> + + * calc/calc.el: Add `backward-delete-char-untabify' to the list of + bindings to remap when `calc-scan-for-dels' is non-nil. + +2007-11-13 Stefan Monnier <monnier@iro.umontreal.ca> + + * emacs-lisp/byte-opt.el (byte-compile-trueconstp): Handle more + constant forms. + (byte-compile-nilconstp): New function. + (byte-optimize-cond): Kill subsequent branches when a branch is + know to be taken or not taken. + (byte-optimize-if): Use byte-compile-nilconstp instead of hand coding. + +2007-11-13 Dan Nicolaescu <dann@ics.uci.edu> + + * vc.el (vc-register): Allow registering a file passed as a + parameter instead of just the current buffer. + +2007-11-12 Michael Albinus <michael.albinus@gmx.de> + + * net/tramp.el (tramp-open-connection-setup-interactive-shell): + Check whether the output of "uname -sr" has been changed. + +2007-11-12 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * progmodes/compile.el (compilation-error-regexp-alist-alist): Insert + patterns from compilation-perl.el and compilation-weblint.el files. + +2007-11-12 Dan Nicolaescu <dann@ics.uci.edu> + + * progmodes/compilation-perl.el: + * progmodes/compilation-weblint.el: Disable autoloads, they cause + a bootstrap failure. + + * vc-cvs.el (vc-cvs-diff): If backup files exist, diff them + instead of doing "cvs diff" in order to avoid accessing the repository. + +2007-11-12 Kevin Ryde <user42@zip.com.au> + + * progmodes/compilation-perl.el: + * progmodes/compilation-weblint.el: New files. + +2007-11-11 Juanma Barranquero <lekktu@gmail.com> + + * international/iso-cvt.el (iso-translate-conventions): Doc fix. + (iso-aggressive-german-trans-tab, iso-conservative-german-trans-tab) + (iso-tex2iso-trans-tab, iso-gtex2iso-trans-tab): Reflow docstring. + (iso-spanish, iso-german, iso-iso2tex, iso-tex2iso, iso-gtex2iso) + (iso-iso2gtex, iso-iso2duden, iso-iso2sgml, iso-sgml2iso): + Rewrite in active voice. + +2007-11-11 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el: Add comments about isearch support. + +2007-11-11 Dan Nicolaescu <dann@ics.uci.edu> + + * vc.el (vc-start-entry): Fix setting the in the case the function + is called from vc-dired. Use when instead of if where appropriate. + +2007-11-11 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el (ps-do-despool): Do not force ps-lpr-switches + to be a list. + (ps-begin-job): Error if ps-lpr-switches is not a list. 2007-11-11 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp> @@ -87,11 +1720,11 @@ 2007-11-10 Dan Nicolaescu <dann@ics.uci.edu> - * emacs-lisp/byte-opt.el (byte-optimize-featurep): Optimize - (featurep 'emacs) to t. + * emacs-lisp/byte-opt.el (byte-optimize-featurep): + Optimize (featurep 'emacs) to t. - * emacs-lisp/bytecomp.el (byte-compile-find-bound-condition): New - function. + * emacs-lisp/bytecomp.el (byte-compile-find-bound-condition): + New function. (byte-compile-maybe-guarded): Use it to also look for bound symbols inside `and' forms. Comment out non-working code that was trying to avoid warnings for XEmacs code. @@ -307,8 +1940,7 @@ * net/tramp-cache.el (tramp-cache-print) (tramp-dump-connection-properties): Fix docstring. - (tramp-list-connections): Rename from - `tramp-cache-list-connections'. + (tramp-list-connections): Rename from `tramp-cache-list-connections'. * net/tramp-cmds.el (tramp-cleanup-connection): Apply it. @@ -458,7 +2090,7 @@ * ediff-diff.el (ediff-set-fine-diff-properties-in-one-buffer): Do not use face-name. - (ediff-test-utility,ediff-diff-mandatory-option) + (ediff-test-utility, ediff-diff-mandatory-option) (ediff-reset-diff-options): Remove to simplify the mandatory option handling on Windows. (ediff-set-diff-options): Add. @@ -830,8 +2462,7 @@ Use feature test instead of boundp test so it can be resolved at compile time. - * net/newsticker.el (replace-regexp-in-string): Only define for - XEmacs. + * net/newsticker.el (replace-regexp-in-string): Only define for XEmacs. 2007-10-30 Stefan Monnier <monnier@iro.umontreal.ca> @@ -886,8 +2517,7 @@ (allout-toggle-current-subtree-exposure): Add new interactive function for toggle subtree exposure - suggested by tassilo. (move-beginning-of-line, move-end-of-line): Don't use - line-move-invisible-p, it's obsolete - substitute the code, - instead. + line-move-invisible-p, it's obsolete - substitute the code, instead. 2007-10-29 Dan Nicolaescu <dann@ics.uci.edu> @@ -2762,7 +4392,7 @@ 2007-10-08 Adam Hupp <adam@hupp.org> (tiny change) - * progmodes/gdb-ui.el (pdb): Specify file for gud-break. + * progmodes/gud.el (pdb): Specify file for gud-break. 2007-10-08 Nick Roberts <nickrob@snap.net.nz> diff --git a/lisp/ChangeLog.12 b/lisp/ChangeLog.12 index 8fc7aa0fa35..cb4924a8930 100644 --- a/lisp/ChangeLog.12 +++ b/lisp/ChangeLog.12 @@ -6411,7 +6411,7 @@ * jit-lock.el (jit-lock-fontify-again): New function. (jit-lock-fontify-now): Use it instead of lambda form. -2006-09-13 Agustin Martin <agustin.martin@hispalinux.es> +2006-09-13 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-word, flyspell-correct-word) (flyspell-auto-correct-word): Make ispell-filter local to these @@ -11561,7 +11561,7 @@ * isearch.el (isearch-other-meta-char): Handle user bindings for shifted control characters. -2006-03-18 Agustin Martin <agustin.martin@hispalinux.es> +2006-03-18 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-skip-region-alist): Add "_+" to the part that matches email addresses, file names, etc. @@ -11856,7 +11856,7 @@ * progmodes/octave-mod.el (octave-indent-for-comment): Behave according to do string. -2006-03-11 Agustin Martin <agustin.martin@hispalinux.es> +2006-03-11 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-menu-map-needed) [ispell-message]: Be visible only if major mode is Mail Mode. @@ -12022,7 +12022,7 @@ (t-mouse-tty, t-mouse-make-event): Doc fix; use imperative. (t-mouse-mode): Remove period from end of error message. -2006-03-03 Agustin Martin <agustin.martin@hispalinux.es> +2006-03-03 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-process-localwords): Be case-sensitive. @@ -12813,7 +12813,7 @@ (remove-from-invisibility-spec, allout-hide-current-subtree): Ditched unused variables. -2006-02-17 Agustin Martin <agustin.martin@hispalinux.es> +2006-02-17 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-change-dictionary): Call ispell-buffer-local-dict instead of @@ -13558,7 +13558,7 @@ described in the docstring for `bs-attributes-list'. (bs--get-name): Simplify. Don't pad the buffer name. -2006-01-27 Agustin Martin <agustin.martin@hispalinux.es> +2006-01-27 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-find-aspell-dictionaries): If no English aspell dictionary is installed, use the first entry of @@ -13849,7 +13849,7 @@ * mail/rmailout.el (rmail-output): Don't use content-type if it is nil. -2006-01-21 Agustin Martin <agustin.martin@hispalinux.es> +2006-01-21 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-emacs-popup, flypell-xemacs-popup): Default to disabling the "Save affix" question. @@ -14005,7 +14005,7 @@ * files.el (auto-mode-alist): Add Imakefile. -2006-01-17 Agustin Martin <agustin.martin@hispalinux.es> +2006-01-17 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (ispell-kill-ispell-hook): Add to the hook when loading the file rather than when turning on flyspell-mode. @@ -14152,7 +14152,7 @@ (org-get-time-of-day): Fix bug with times before 1am. (org-agenda-menu): Add tags commands. -2006-01-13 Agustin Martin <agustin.martin@hispalinux.es> +2006-01-13 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/ispell.el (ispell-init-process): Include the used dictionary in ispell process start message. @@ -14842,7 +14842,7 @@ Use local var buffer-scan-pos to advance scan for next misspelling. Advance it only after we find the misspelling. -2005-12-27 Agustin Martin <agustin.martin@hispalinux.es> +2005-12-27 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-external-point-words): New criteria for finding the misspelling in the buffer. @@ -17232,7 +17232,7 @@ * international/latexenc.el (latex-inputenc-coding-alist): Doc fix. -2005-12-02 Agustin Martin <agustin.martin@hispalinux.es> +2005-12-02 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-external-point-words): Consider a misspelling as found in the string search if: (a) misspelling @@ -18221,7 +18221,7 @@ * textmodes/flyspell.el (flyspell-large-region): Call flyspell-accept-buffer-local-defs. -2005-11-13 Agustin Martin <agustin.martin@hispalinux.es> +2005-11-13 Agust,Am(Bn Mart,Am(Bn <agustin.martin@hispalinux.es> * textmodes/flyspell.el (flyspell-notify-misspell): Fix misspelling of "Misspelling". diff --git a/lisp/ChangeLog.unicode b/lisp/ChangeLog.unicode index b12b4b5cb71..4c42467b605 100644 --- a/lisp/ChangeLog.unicode +++ b/lisp/ChangeLog.unicode @@ -83,6 +83,10 @@ * international/mule-cmds.el (describe-language-environment): Check if the specified input method exists or not. +2007-11-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * ldefs-boot.el: Regenerate. + 2007-11-11 Vinicius Jose Latorre <viniciusjl@ig.com.br> * ps-print.el (ps-do-despool): Do not force ps-lpr-switches to be a diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 06457607c5a..a221ccdf4a4 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -297,9 +297,12 @@ bootstrap-prepare: $(lisp)/ps-print.el \ $(lisp)/emacs-lisp/cl-loaddefs.el -maintainer-clean: distclean - cd $(lisp); rm -f *.elc */*.elc $(AUTOGENEL) +maintainer-clean: distclean bootstrap-clean + cd $(lisp); rm -f $(AUTOGENEL) +## NB note that this rules assume only one level of subdirs below lisp/. +## If nested subdirs are added, it's probably time to switch to: +## find $(lisp) -name "*.elc" -exec rm -f '{}' ';' bootstrap-clean: cd $(lisp); rm -f *.elc */*.elc @@ -315,4 +318,10 @@ bootstrap-after: finder-data custom-deps distclean: -rm -f ./Makefile +.PHONY: check-declare + +check-declare: + $(emacs) -l $(lisp)/emacs-lisp/check-declare \ + --eval '(check-declare-directory "$(lisp)")' + # Makefile ends here. diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 0c140a84159..d7dfea2f6d8 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -83,10 +83,8 @@ to enable or disable Abbrev mode in the current buffer." (defun kill-all-abbrevs () "Undefine all defined abbrevs." (interactive) - (let ((tables abbrev-table-name-list)) - (while tables - (clear-abbrev-table (symbol-value (car tables))) - (setq tables (cdr tables))))) + (dolist (tablesym abbrev-table-name-list) + (clear-abbrev-table (symbol-value tablesym)))) (defun copy-abbrev-table (table) "Make a new abbrev-table with the same abbrevs as TABLE." @@ -106,10 +104,8 @@ Mark is set after the inserted text." (interactive) (push-mark (save-excursion - (let ((tables abbrev-table-name-list)) - (while tables - (insert-abbrev-table-description (car tables) t) - (setq tables (cdr tables)))) + (dolist (tablesym abbrev-table-name-list) + (insert-abbrev-table-description tablesym t)) (point)))) (defun list-abbrevs (&optional local) @@ -131,18 +127,17 @@ Otherwise display all abbrevs." found)) (defun prepare-abbrev-list-buffer (&optional local) - (save-excursion - (let ((table local-abbrev-table)) - (set-buffer (get-buffer-create "*Abbrevs*")) - (erase-buffer) - (if local - (insert-abbrev-table-description (abbrev-table-name table) t) - (dolist (table abbrev-table-name-list) - (insert-abbrev-table-description table t))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (edit-abbrevs-mode) - (current-buffer)))) + (with-current-buffer (get-buffer-create "*Abbrevs*") + (erase-buffer) + (if local + (insert-abbrev-table-description + (abbrev-table-name local-abbrev-table) t) + (dolist (table abbrev-table-name-list) + (insert-abbrev-table-description table t))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (edit-abbrevs-mode) + (current-buffer))) (defun edit-abbrevs-mode () "Major mode for editing the list of abbrev definitions. @@ -524,8 +519,14 @@ the current abbrev table before abbrev lookup happens." (defun clear-abbrev-table (table) "Undefine all abbrevs in abbrev table TABLE, leaving it empty." (setq abbrevs-changed t) - (dotimes (i (length table)) - (aset table i 0))) + (let* ((sym (intern-soft "" table))) + (dotimes (i (length table)) + (aset table i 0)) + ;; Preserve the table's properties. + (assert sym) + (intern sym table) + (abbrev-table-put table :abbrev-table-modiff + (1+ (abbrev-table-get table :abbrev-table-modiff))))) (defun define-abbrev (table name expansion &optional hook &rest props) "Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK. @@ -825,7 +826,7 @@ Only writes the non-system abbrevs. Presumes that `standard-output' points to `current-buffer'." (unless (or (null (symbol-value sym)) (abbrev-get sym :system)) (insert " (") - (prin1 sym) + (prin1 (symbol-name sym)) (insert " ") (prin1 (symbol-value sym)) (insert " ") diff --git a/lisp/add-log.el b/lisp/add-log.el index 3ca1b613955..33ecd98ec44 100644 --- a/lisp/add-log.el +++ b/lisp/add-log.el @@ -664,7 +664,6 @@ the change log file in another window." (list current-prefix-arg (prompt-for-change-log-name)))) (add-change-log-entry whoami file-name t)) -;;;###autoload (define-key ctl-x-4-map "a" 'add-change-log-entry-other-window) (defvar change-log-indent-text 0) @@ -827,6 +826,9 @@ Prefix arg means justify as well." '(TeX-mode plain-TeX-mode LaTeX-mode tex-mode) "*Modes that look like TeX to `add-log-current-defun'.") +(declare-function c-beginning-of-defun "cc-cmds" (&optional arg)) +(declare-function c-end-of-defun "cc-cmds" (&optional arg)) + ;;;###autoload (defun add-log-current-defun () "Return name of function definition point is in, or nil. diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 421283da9e0..3cfd07398c5 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -728,6 +728,9 @@ archive. ;; Note this regexp is also in archive-exe-p. ((looking-at "MZ\\(.\\|\n\\)\\{34\\}LH[aA]'s SFX ") 'lzh-exe) ((looking-at "Rar!") 'rar) + ((and (looking-at "MZ") + (re-search-forward "Rar!" (+ (point) 100000) t)) + 'rar-exe) (t (error "Buffer format not recognized"))))) ;; ------------------------------------------------------------------------- @@ -1860,10 +1863,10 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; ------------------------------------------------------------------------- ;;; Section: Rar Archives -(defun archive-rar-summarize () - (let* ((file buffer-file-name) - (copy (file-local-copy file)) - header footer +(defun archive-rar-summarize (&optional file) + ;; File is used internally for `archive-rar-exe-summarize'. + (unless file (setq file buffer-file-name)) + (let* ((copy (file-local-copy file)) (maxname 10) (maxsize 5) (files ())) @@ -1872,9 +1875,6 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (if copy (delete-file copy)) (goto-char (point-min)) (re-search-forward "^-+\n") - (setq header - (buffer-substring (save-excursion (re-search-backward "^[^ ]")) - (point))) (while (looking-at (concat " \\(.*\\)\n" ;Name. ;; Size ; Packed. " +\\([0-9]+\\) +[0-9]+" @@ -1894,8 +1894,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." size (match-string 3) ;; Date, Time. (match-string 4) (match-string 5)) - files))) - (setq footer (buffer-substring (point) (point-max)))) + files)))) (setq files (nreverse files)) (goto-char (point-min)) (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize)) @@ -1937,9 +1936,44 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (delete-directory (expand-file-name name dest))) (delete-directory dest))))) +;;; Section: Rar self-extracting .exe archives. + +(defun archive-rar-exe-summarize () + (let ((tmpfile (make-temp-file "rarexe"))) + (unwind-protect + (progn + (goto-char (point-min)) + (re-search-forward "Rar!") + (write-region (match-beginning 0) (point-max) tmpfile) + (archive-rar-summarize tmpfile)) + (delete-file tmpfile)))) + +(defun archive-rar-exe-extract (archive name) + (let* ((tmpfile (make-temp-file "rarexe")) + (buf (find-buffer-visiting archive)) + (tmpbuf (unless buf (generate-new-buffer " *rar-exe*")))) + (unwind-protect + (progn + (with-current-buffer (or buf tmpbuf) + (save-excursion + (save-restriction + (if buf + ;; point-max unwidened is assumed to be the end of the + ;; summary text and the beginning of the actual file data. + (progn (goto-char (point-max)) (widen)) + (insert-file-contents-literally archive) + (goto-char (point-min))) + (re-search-forward "Rar!") + (write-region (match-beginning 0) (point-max) tmpfile)))) + (archive-rar-extract tmpfile name)) + (if tmpbuf (kill-buffer tmpbuf)) + (delete-file tmpfile)))) + + ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility. ;; rms 15 Oct 98 + (provide 'archive-mode) (provide 'arc-mode) diff --git a/lisp/bindings.el b/lisp/bindings.el index 1bc31e04bb9..ead6ac51577 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -704,7 +704,8 @@ language you are using." ;; Override the global binding (which calls indent-relative via ;; indent-for-tab-command). The alignment that indent-relative tries to ;; do doesn't make much sense here since the prompt messes it up. - (define-key map "\t" 'self-insert-command)) + (define-key map "\t" 'self-insert-command) + (define-key minibuffer-local-map [C-tab] 'file-cache-minibuffer-complete)) (define-key global-map "\C-u" 'universal-argument) (let ((i ?0)) @@ -1073,6 +1074,9 @@ language you are using." (define-key ctl-x-map "z" 'repeat) +(define-key esc-map "\C-l" 'reposition-window) + +(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window) (define-key ctl-x-4-map "c" 'clone-indirect-buffer-other-window) ;; Signal handlers diff --git a/lisp/calc/README b/lisp/calc/README index dc474c43813..fbbd73b8fee 100644 --- a/lisp/calc/README +++ b/lisp/calc/README @@ -72,6 +72,8 @@ opinions. Summary of changes to "Calc" ------- -- ------- -- ---- +* Added a menu. + * Added logistic non-linear curves to curve-fitting. * Added option of plotting data points and curve when curve-fitting. diff --git a/lisp/calc/calc-aent.el b/lisp/calc/calc-aent.el index ffd07bd8f2e..697d510ac02 100644 --- a/lisp/calc/calc-aent.el +++ b/lisp/calc/calc-aent.el @@ -32,6 +32,25 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-refresh-evaltos "calc-ext" (&optional which-var)) +(declare-function calc-execute-kbd-macro "calc-prog" (mac arg &rest prefix)) +(declare-function math-is-true "calc-ext" (expr)) +(declare-function calc-explain-why "calc-stuff" (why &optional more)) +(declare-function calc-alg-edit "calc-yank" (str)) +(declare-function math-composite-inequalities "calc-prog" (x op)) +(declare-function math-flatten-lands "calc-rewr" (expr)) +(declare-function math-multi-subst "calc-map" (expr olds news)) +(declare-function calcFunc-vmatches "calc-rewr" (expr pat)) +(declare-function math-simplify "calc-alg" (top-expr)) +(declare-function math-known-matrixp "calc-arith" (a)) +(declare-function math-parse-fortran-subscr "calc-lang" (sym args)) +(declare-function math-to-radians-2 "calc-math" (a)) +(declare-function math-read-string "calc-ext" ()) +(declare-function math-read-brackets "calc-vec" (space-sep math-rb-close)) +(declare-function math-read-angle-brackets "calc-forms" ()) + + (defvar calc-quick-calc-history nil "The history list for quick-calc.") @@ -603,6 +622,7 @@ in Calc algebraic input.") (defvar calc-user-parse-table nil) (defvar calc-last-main-parse-table nil) +(defvar calc-last-user-lang-parse-table nil) (defvar calc-last-lang-parse-table nil) (defvar calc-user-tokens nil) (defvar calc-user-token-chars nil) @@ -612,10 +632,12 @@ in Calc algebraic input.") (defun math-build-parse-table () (let ((mtab (cdr (assq nil calc-user-parse-tables))) - (ltab (cdr (assq calc-language calc-user-parse-tables)))) + (ltab (cdr (assq calc-language calc-user-parse-tables))) + (lltab (get calc-language 'math-parse-table))) (or (and (eq mtab calc-last-main-parse-table) - (eq ltab calc-last-lang-parse-table)) - (let ((p (append mtab ltab)) + (eq ltab calc-last-user-lang-parse-table) + (eq lltab calc-last-lang-parse-table)) + (let ((p (append mtab ltab lltab)) (math-toks nil)) (setq calc-user-parse-table p) (setq calc-user-token-chars nil) @@ -629,7 +651,8 @@ in Calc algebraic input.") (length y))))) "\\|") calc-last-main-parse-table mtab - calc-last-lang-parse-table ltab))))) + calc-last-user-lang-parse-table ltab + calc-last-lang-parse-table lltab))))) (defun math-find-user-tokens (p) (while p @@ -660,7 +683,8 @@ in Calc algebraic input.") (setq math-exp-old-pos math-exp-pos math-exp-token 'end math-expr-data "\000") - (let ((ch (aref math-exp-str math-exp-pos))) + (let (adfn + (ch (aref math-exp-str math-exp-pos))) (setq math-exp-old-pos math-exp-pos) (cond ((memq ch '(32 10 9)) (setq math-exp-pos (1+ math-exp-pos)) @@ -677,7 +701,7 @@ in Calc algebraic input.") math-exp-pos (match-end 0))) ((or (and (>= ch ?a) (<= ch ?z)) (and (>= ch ?A) (<= ch ?Z))) - (string-match (if (memq calc-language '(c fortran pascal maple)) + (string-match (if (memq calc-language calc-lang-allow-underscores) "[a-zA-Z0-9_#]*" "[a-zA-Z0-9'#]*") math-exp-str math-exp-pos) @@ -685,22 +709,8 @@ in Calc algebraic input.") math-exp-pos (match-end 0) math-expr-data (math-restore-dashes (math-match-substring math-exp-str 0))) - (if (eq calc-language 'eqn) - (let ((code (assoc math-expr-data math-eqn-ignore-words))) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((consp (nth 1 code)) - (math-read-token) - (if (assoc math-expr-data (cdr code)) - (setq math-expr-data (format "%s %s" - (car code) math-expr-data)))) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - (t - (math-read-token) - (math-read-token)))))) + (if (setq adfn (get calc-language 'math-lang-adjust-words)) + (funcall adfn))) ((or (and (>= ch ?0) (<= ch ?9)) (and (eq ch '?\.) (eq (string-match "\\.[0-9]" math-exp-str math-exp-pos) @@ -709,35 +719,31 @@ in Calc algebraic input.") (eq (string-match "_\\.?[0-9]" math-exp-str math-exp-pos) math-exp-pos) (or (eq math-exp-pos 0) - (and (memq calc-language '(nil flat big unform - tex latex eqn)) + (and (not (memq calc-language + calc-lang-allow-underscores)) (eq (string-match "[^])}\"a-zA-Z0-9'$]_" math-exp-str (1- math-exp-pos)) (1- math-exp-pos)))))) - (or (and (eq calc-language 'c) + (or (and (memq calc-language calc-lang-c-type-hex) (string-match "0[xX][0-9a-fA-F]+" math-exp-str math-exp-pos)) (string-match "_?\\([0-9]+.?0*@ *\\)?\\([0-9]+.?0*' *\\)?\\(0*\\([2-9]\\|1[0-4]\\)\\(#\\|\\^\\^\\)[0-9a-dA-D.]+[eE][-+_]?[0-9]+\\|0*\\([2-9]\\|[0-2][0-9]\\|3[0-6]\\)\\(#\\|\\^\\^\\)[0-9a-zA-Z:.]+\\|[0-9]+:[0-9:]+\\|[0-9.]+\\([eE][-+_]?[0-9]+\\)?\"?\\)?" math-exp-str math-exp-pos)) (setq math-exp-token 'number math-expr-data (math-match-substring math-exp-str 0) math-exp-pos (match-end 0))) + ((and (setq adfn + (assq ch (get calc-language 'math-lang-read-symbol))) + (eval (nth 1 adfn))) + (eval (nth 2 adfn))) ((eq ch ?\$) - (if (and (eq calc-language 'pascal) - (eq (string-match - "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" - math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'number - math-expr-data (math-match-substring math-exp-str 1) - math-exp-pos (match-end 1)) - (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) - math-exp-pos) - (setq math-expr-data (- (string-to-number (math-match-substring - math-exp-str 1)))) - (string-match "\\$+" math-exp-str math-exp-pos) - (setq math-expr-data (- (match-end 0) (match-beginning 0)))) - (setq math-exp-token 'dollar - math-exp-pos (match-end 0)))) + (if (eq (string-match "\\$\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) + math-exp-pos) + (setq math-expr-data (- (string-to-number (math-match-substring + math-exp-str 1)))) + (string-match "\\$+" math-exp-str math-exp-pos) + (setq math-expr-data (- (match-end 0) (match-beginning 0)))) + (setq math-exp-token 'dollar + math-exp-pos (match-end 0))) ((eq ch ?\#) (if (eq (string-match "#\\([1-9][0-9]*\\)" math-exp-str math-exp-pos) math-exp-pos) @@ -756,120 +762,18 @@ in Calc algebraic input.") ((and (eq ch ?\") (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" math-exp-str math-exp-pos)) - (if (eq calc-language 'eqn) - (progn - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str (match-beginning 1) ?\{) - (if (< (match-end 1) (length math-exp-str)) - (aset math-exp-str (match-end 1) ?\})) - (math-read-token)) - (setq math-exp-token 'string - math-expr-data (math-match-substring math-exp-str 1) - math-exp-pos (match-end 0)))) - ((and (= ch ?\\) (eq calc-language 'tex) - (< math-exp-pos (1- (length math-exp-str)))) - (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" - math-exp-str math-exp-pos)) - (setq math-exp-token 'symbol - math-exp-pos (match-end 0) - math-expr-data (math-restore-dashes - (math-match-substring math-exp-str 1))) - (let ((code (assoc math-expr-data math-latex-ignore-words))) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - ((and (eq (nth 1 code) 'mat) - (string-match " *{" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - math-exp-token 'punc - math-expr-data "[") - (let ((right (string-match "}" math-exp-str math-exp-pos))) - (and right - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str right ?\]))))))) - ((and (= ch ?\\) (eq calc-language 'latex) - (< math-exp-pos (1- (length math-exp-str)))) - (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}" - math-exp-str math-exp-pos) - (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" - math-exp-str math-exp-pos)) - (setq math-exp-token 'symbol - math-exp-pos (match-end 0) - math-expr-data (math-restore-dashes - (math-match-substring math-exp-str 1))) - (let ((code (assoc math-expr-data math-tex-ignore-words)) - envname) - (cond ((null code)) - ((null (cdr code)) - (math-read-token)) - ((eq (nth 1 code) 'punc) - (setq math-exp-token 'punc - math-expr-data (nth 2 code))) - ((and (eq (nth 1 code) 'begenv) - (string-match " *{\\([^}]*\\)}" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - envname (match-string 1 math-exp-str) - math-exp-token 'punc - math-expr-data "[") - (cond ((or (string= envname "matrix") - (string= envname "bmatrix") - (string= envname "smallmatrix") - (string= envname "pmatrix")) - (if (string-match (concat "\\\\end{" envname "}") - math-exp-str math-exp-pos) - (setq math-exp-str - (replace-match "]" t t math-exp-str)) - (error "%s" (concat "No closing \\end{" envname "}")))))) - ((and (eq (nth 1 code) 'mat) - (string-match " *{" math-exp-str math-exp-pos)) - (setq math-exp-pos (match-end 0) - math-exp-token 'punc - math-expr-data "[") - (let ((right (string-match "}" math-exp-str math-exp-pos))) - (and right - (setq math-exp-str (copy-sequence math-exp-str)) - (aset math-exp-str right ?\]))))))) - ((and (= ch ?\.) (eq calc-language 'fortran) - (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." - math-exp-str math-exp-pos) math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (upcase (math-match-substring math-exp-str 0)) - math-exp-pos (match-end 0))) - ((and (eq calc-language 'math) - (eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (math-match-substring math-exp-str 0) - math-exp-pos (match-end 0))) - ((and (eq calc-language 'eqn) - (eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" - math-exp-str math-exp-pos) - math-exp-pos)) - (setq math-exp-token 'punc - math-expr-data (math-match-substring math-exp-str 0) - math-exp-pos (match-end 0)) - (and (eq (string-match "\\\\dots\\." math-exp-str math-exp-pos) - math-exp-pos) - (setq math-exp-pos (match-end 0))) - (if (memq (aref math-expr-data 0) '(?~ ?^)) - (math-read-token))) + (setq math-exp-token 'string + math-expr-data (math-match-substring math-exp-str 1) + math-exp-pos (match-end 0))) + ((and (setq adfn (get calc-language 'math-lang-read))) + (eval (nth 0 adfn)) + (eval (nth 1 adfn))) ((eq (string-match "%%.*$" math-exp-str math-exp-pos) math-exp-pos) (setq math-exp-pos (match-end 0)) (math-read-token)) (t - (if (and (eq ch ?\{) (memq calc-language '(tex latex eqn))) - (setq ch ?\()) - (if (and (eq ch ?\}) (memq calc-language '(tex latex eqn))) - (setq ch ?\))) - (if (and (eq ch ?\&) (memq calc-language '(tex latex))) - (setq ch ?\,)) + (if (setq adfn (assq ch (get calc-language 'math-punc-table))) + (setq ch (cdr adfn))) (setq math-exp-token 'punc math-expr-data (char-to-string ch) math-exp-pos (1+ math-exp-pos))))))) @@ -902,7 +806,9 @@ in Calc algebraic input.") (memq math-exp-token '(symbol number dollar hash)) (equal math-expr-data "(") (and (equal math-expr-data "[") - (not (eq calc-language 'math)) + (not (equal + (get calc-language + 'math-function-open) "[")) (not (and math-exp-keep-spaces (eq (car-safe x) 'vec))))) (or (not (setq op (assoc math-expr-data math-expr-opers))) @@ -1178,7 +1084,9 @@ in Calc algebraic input.") (eq math-exp-token 'end))) (throw 'syntax "Expected `)'")) (math-read-token) - (if (and (eq calc-language 'fortran) args + (if (and (memq calc-language + calc-lang-parens-are-subscripts) + args (require 'calc-ext) (let ((calc-matrix-mode 'scalar)) (math-known-matrixp @@ -1216,11 +1124,15 @@ in Calc algebraic input.") (substring (symbol-name (cdr v)) 4)) (cdr v)))))) - (while (and (memq calc-language '(c pascal maple)) + (while (and (memq calc-language + calc-lang-brackets-are-subscripts) (equal math-expr-data "[")) (math-read-token) - (setq val (append (list 'calcFunc-subscr val) - (math-read-expr-list))) + (let ((el (math-read-expr-list))) + (while el + (setq val (append (list 'calcFunc-subscr val) + (list (car el)))) + (setq el (cdr el)))) (if (equal math-expr-data "]") (math-read-token) (throw 'syntax "Expected ']'"))) diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index bb054de4951..140335a3d02 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -30,6 +30,51 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function math-clip "calc-bin" (a &optional w)) +(declare-function math-round "calc-arith" (a &optional prec)) +(declare-function math-simplify "calc-alg" (top-expr)) +(declare-function math-simplify-extended "calc-alg" (a)) +(declare-function math-simplify-units "calc-units" (a)) +(declare-function calc-set-language "calc-lang" (lang &optional option no-refresh)) +(declare-function calc-flush-caches "calc-stuff" (&optional inhibit-msg)) +(declare-function calc-save-modes "calc-mode" ()) +(declare-function calc-embedded-modes-change "calc-embed" (vars)) +(declare-function calc-embedded-var-change "calc-embed" (var &optional buf)) +(declare-function math-mul-float "calc-arith" (a b)) +(declare-function math-arctan-raw "calc-math" (x)) +(declare-function math-sqrt-raw "calc-math" (a &optional guess)) +(declare-function math-sqrt-float "calc-math" (a &optional guess)) +(declare-function math-exp-minus-1-raw "calc-math" (x)) +(declare-function math-normalize-polar "calc-cplx" (a)) +(declare-function math-normalize-hms "calc-forms" (a)) +(declare-function math-normalize-mod "calc-forms" (a)) +(declare-function math-make-sdev "calc-forms" (x sigma)) +(declare-function math-make-intv "calc-forms" (mask lo hi)) +(declare-function math-normalize-logical-op "calc-prog" (a)) +(declare-function math-possible-signs "calc-arith" (a &optional origin)) +(declare-function math-infinite-dir "calc-math" (a &optional inf)) +(declare-function math-calcFunc-to-var "calc-map" (f)) +(declare-function calc-embedded-evaluate-expr "calc-embed" (x)) +(declare-function math-known-nonzerop "calc-arith" (a)) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) +(declare-function math-read-big-rec "calc-lang" (math-rb-h1 math-rb-v1 math-rb-h2 math-rb-v2 &optional baseline prec short)) +(declare-function math-read-big-balance "calc-lang" (h v what &optional commas)) +(declare-function math-format-date "calc-forms" (math-fd-date)) +(declare-function math-vector-is-string "calccomp" (a)) +(declare-function math-vector-to-string "calccomp" (a &optional quoted)) +(declare-function math-format-radix-float "calc-bin" (a prec)) +(declare-function math-compose-expr "calccomp" (a prec)) +(declare-function math-abs "calc-arith" (a)) +(declare-function math-format-bignum-binary "calc-bin" (a)) +(declare-function math-format-bignum-octal "calc-bin" (a)) +(declare-function math-format-bignum-hex "calc-bin" (a)) +(declare-function math-format-bignum-radix "calc-bin" (a)) +(declare-function math-compute-max-digits "calc-bin" (w r)) +(declare-function math-map-vec "calc-vec" (f a)) +(declare-function math-make-frac "calc-frac" (num den)) + + (defvar math-simplifying nil) (defvar math-living-dangerously nil) ; true if unsafe simplifications are okay. (defvar math-integrating nil) @@ -2090,7 +2135,7 @@ calc-kill calc-kill-region calc-yank)))) ;;; True if A is a real or will evaluate to a real. [P x] [Public] (defun math-provably-realp (a) (or (Math-realp a) - (math-provably-integer a) + (math-provably-integerp a) (memq (car-safe a) '(abs arg)))) ;;; True if A is a non-real, complex number. [P x] [Public] diff --git a/lisp/calc/calc-forms.el b/lisp/calc/calc-forms.el index 3839fc93666..13048c85dce 100644 --- a/lisp/calc/calc-forms.el +++ b/lisp/calc/calc-forms.el @@ -32,6 +32,12 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calendar-current-time-zone "cal-dst" ()) +(declare-function calendar-absolute-from-gregorian "calendar" (date)) +(declare-function dst-in-effect "cal-dst" (date)) + + (defun calc-time () (interactive) (calc-wrapper diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index ed1c93e8694..49d1fd937ba 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -32,6 +32,11 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function Info-goto-node "info" (nodename &optional fork)) +(declare-function Info-last "info" ()) + + (defun calc-help-prefix (arg) "This key is the prefix for Calc help functions. See calc-help-for-help." (interactive "P") diff --git a/lisp/calc/calc-lang.el b/lisp/calc/calc-lang.el index 3871a1b0f09..2ae23cd5aa9 100644 --- a/lisp/calc/calc-lang.el +++ b/lisp/calc/calc-lang.el @@ -32,12 +32,27 @@ (require 'calc-ext) (require 'calc-macs) + +;; Declare functions which are defined elsewhere. +(declare-function math-compose-vector "calccomp" (a sep prec)) +(declare-function math-compose-var "calccomp" (a)) +(declare-function math-tex-expr-is-flat "calccomp" (a)) +(declare-function math-read-factor "calc-aent" ()) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + +;; Declare variables which are defined elsewhere. +(defvar calc-lang-slash-idiv) +(defvar calc-lang-allow-underscores) +(defvar math-comp-left-bracket) +(defvar math-comp-right-bracket) +(defvar math-comp-comma) +(defvar math-comp-vector-prec) + ;;; Alternate entry/display languages. (defun calc-set-language (lang &optional option no-refresh) (setq math-expr-opers (or (get lang 'math-oper-table) (math-standard-ops)) math-expr-function-mapping (get lang 'math-function-table) - math-expr-special-function-mapping (get lang 'math-special-function-table) math-expr-variable-mapping (get lang 'math-variable-table) calc-language-input-filter (get lang 'math-input-filter) calc-language-output-filter (get lang 'math-output-filter) @@ -135,6 +150,20 @@ (if (= r 8) (format "0%s" s) (format "%d#%s" r s)))))) +(put 'c 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-slash-idiv 'c) +(add-to-list 'calc-lang-allow-underscores 'c) +(add-to-list 'calc-lang-c-type-hex 'c) +(add-to-list 'calc-lang-brackets-are-subscripts 'c) (defun calc-pascal-language (n) (interactive "P") @@ -183,6 +212,32 @@ (if (= r 16) (format "$%s" s) (format "%d#%s" r s))))) +(put 'pascal 'math-lang-read-symbol + '((?\$ + (eq (string-match + "\\(\\$[0-9a-fA-F]+\\)\\($\\|[^0-9a-zA-Z]\\)" + math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-token 'number + math-expr-data (math-match-substring math-exp-str 1) + math-exp-pos (match-end 1))))) + +(put 'pascal 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-allow-underscores 'pascal) +(add-to-list 'calc-lang-brackets-are-subscripts 'pascal) + (defun calc-input-case-filter (str) (cond ((or (null calc-language-option) (= calc-language-option 0)) str) @@ -253,8 +308,34 @@ ( real . calcFunc-re ))) (put 'fortran 'math-input-filter 'calc-input-case-filter) + (put 'fortran 'math-output-filter 'calc-output-case-filter) +(put 'fortran 'math-lang-read-symbol + '((?\. + (eq (string-match "\\.[a-zA-Z][a-zA-Z][a-zA-Z]?\\." + math-exp-str math-exp-pos) math-exp-pos) + (setq math-exp-token 'punc + math-expr-data (upcase (math-match-substring math-exp-str 0)) + math-exp-pos (match-end 0))))) + +(put 'fortran 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (while (eq (car-safe (nth 1 a)) 'calcFunc-subscr) + (setq args (append (cdr (cdr (nth 1 a))) args) + a (nth 1 a))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "(" + (math-compose-vector args ", " 0) + ")"))))) + +(add-to-list 'calc-lang-slash-idiv 'fortran) +(add-to-list 'calc-lang-allow-underscores 'fortran) +(add-to-list 'calc-lang-parens-are-subscripts 'fortran) + ;; The next few variables are local to math-read-exprs in calc-aent.el ;; and math-read-expr in calc-ext.el, but are set in functions they call. @@ -354,10 +435,10 @@ ( "\\times" * 191 190 ) ( "*" * 191 190 ) ( "2x" * 191 190 ) - ( "/" / 185 186 ) ( "+" + 180 181 ) ( "-" - 180 181 ) ( "\\over" / 170 171 ) + ( "/" / 170 171 ) ( "\\choose" calcFunc-choose 170 171 ) ( "\\mod" % 170 171 ) ( "<" calcFunc-lt 160 161 ) @@ -408,6 +489,11 @@ ( \\phi . calcFunc-totient ) ( \\mu . calcFunc-moebius ))) +(put 'tex 'math-special-function-table + '((calcFunc-sum . (math-compose-tex-sum "\\sum")) + (calcFunc-prod . (math-compose-tex-sum "\\prod")) + (intv . math-compose-tex-intv))) + (put 'tex 'math-variable-table '( ;; The Greek letters @@ -458,8 +544,112 @@ ( \\sum . (math-parse-tex-sum calcFunc-sum) ) ( \\prod . (math-parse-tex-sum calcFunc-prod) ))) +(put 'tex 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)) + (?\& . ?\,))) + (put 'tex 'math-complex-format 'i) +(put 'tex 'math-input-filter 'math-tex-input-filter) + +(put 'tex 'math-matrix-formatter + (function + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\matrix{") + (math-compose-tex-matrix (cdr a)) + '("}")) + (append '(horiz "\\matrix{ ") + (math-compose-tex-matrix (cdr a)) + '(" }")))))) + +(put 'tex 'math-var-formatter 'math-compose-tex-var) + +(put 'tex 'math-func-formatter 'math-compose-tex-func) + +(put 'tex 'math-dots "\\ldots") + +(put 'tex 'math-big-parens '("\\left( " . " \\right)")) + +(put 'tex 'math-evalto '("\\evalto " . " \\to ")) + +(defconst math-tex-ignore-words + '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") + ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") + ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") + ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") + ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") + ("\\rm") ("\\bf") ("\\it") ("\\sl") + ("\\roman") ("\\bold") ("\\italic") ("\\slanted") + ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") + ("\\evalto") + ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) + ("\\begin" begenv) + ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") + ("\\{" punc "[") ("\\}" punc "]"))) + +(defconst math-latex-ignore-words + (append math-tex-ignore-words + '(("\\begin" begenv)))) + +(put 'tex 'math-lang-read-symbol + '((?\\ + (< math-exp-pos (1- (length math-exp-str))) + (progn + (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" + math-exp-str math-exp-pos)) + (setq math-exp-token 'symbol + math-exp-pos (match-end 0) + math-expr-data (math-restore-dashes + (math-match-substring math-exp-str 1))) + (let ((code (assoc math-expr-data math-latex-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + ((and (eq (nth 1 code) 'mat) + (string-match " *{" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + math-exp-token 'punc + math-expr-data "[") + (let ((right (string-match "}" math-exp-str math-exp-pos))) + (and right + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str right ?\])))))))))) + +(defun math-compose-tex-matrix (a &optional ltx) + (if (cdr a) + (cons (append (math-compose-vector (cdr (car a)) " & " 0) + (if ltx '(" \\\\ ") '(" \\cr "))) + (math-compose-tex-matrix (cdr a) ltx)) + (list (math-compose-vector (cdr (car a)) " & " 0)))) + +(defun math-compose-tex-sum (a fn) + (cond + ((nth 4 a) + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}^{" (math-compose-expr (nth 4 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + ((nth 3 a) + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "=" (math-compose-expr (nth 3 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")) + (t + (list 'horiz (nth 1 fn) + "_{" (math-compose-expr (nth 2 a) 0) + "}{" (math-compose-expr (nth 1 a) 0) "}")))) + (defun math-parse-tex-sum (f val) (let (low high save) (or (equal math-expr-data "_") (throw 'syntax "Expected `_'")) @@ -480,7 +670,59 @@ (setq str (concat (substring str 0 (1+ (match-beginning 0))) (substring str (1- (match-end 0)))))) str) -(put 'tex 'math-input-filter 'math-tex-input-filter) + +;(defun math-tex-print-sqrt (a) +; (list 'horiz +; "\\sqrt{" +; (math-compose-expr (nth 1 a) 0) +; "}")) + +(defun math-compose-tex-intv (a) + (list 'horiz + (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-compose-expr (nth 2 a) 0) + " \\ldots " + (math-compose-expr (nth 3 a) 0) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + +(defun math-compose-tex-var (a prec) + (if (and calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" + (symbol-name (nth 1 a)))) + (if (eq calc-language 'latex) + (format "\\text{%s}" (symbol-name (nth 1 a))) + (format "\\hbox{%s}" (symbol-name (nth 1 a)))) + (math-compose-var a))) + +(defun math-compose-tex-func (func a) + (let (left right) + (if (and calc-language-option + (not (= calc-language-option 0)) + (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) + (if (< (prefix-numeric-value calc-language-option) 0) + (setq func (format "\\%s" func)) + (setq func (if (eq calc-language 'latex) + (format "\\text{%s}" func) + (format "\\hbox{%s}" func))))) + (cond ((or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a)))) + (setq left "\\left( " + right " \\right)")) + ((and (eq (aref func 0) ?\\) + (not (or + (string-match "\\hbox{" func) + (string-match "\\text{" func))) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left "{" right "}")) + (t (setq left calc-function-open + right calc-function-close))) + (list 'horiz func + left + (math-compose-vector (cdr a) ", " 0) + right))) (put 'latex 'math-oper-table (append (get 'tex 'math-oper-table) @@ -496,7 +738,7 @@ ( "\\Vec" calcFunc-VEC -1 950 ) ( "\\dddot" calcFunc-dddot -1 950 ) ( "\\ddddot" calcFunc-ddddot -1 950 ) - ( "\div" / 170 171 ) + ( "\\div" / 170 171 ) ( "\\le" calcFunc-leq 160 161 ) ( "\\leqq" calcFunc-leq 160 161 ) ( "\\leqsland" calcFunc-leq 160 161 ) @@ -534,15 +776,93 @@ ( \\mu . calcFunc-moebius )))) (put 'latex 'math-special-function-table - '((/ . (math-latex-print-frac "\\frac")) - (calcFunc-choose . (math-latex-print-frac "\\binom")))) + '((/ . (math-compose-latex-frac "\\frac")) + (calcFunc-choose . (math-compose-latex-frac "\\binom")) + (calcFunc-sum . (math-compose-tex-sum "\\sum")) + (calcFunc-prod . (math-compose-tex-sum "\\prod")) + (intv . math-compose-tex-intv))) (put 'latex 'math-variable-table (get 'tex 'math-variable-table)) -(put 'latex 'math-complex-format 'i) +(put 'latex 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)) + (?\& . ?\,))) +(put 'latex 'math-complex-format 'i) +(put 'latex 'math-matrix-formatter + (function + (lambda (a) + (if (and (integerp calc-language-option) + (or (= calc-language-option 0) + (> calc-language-option 1) + (< calc-language-option -1))) + (append '(vleft 0 "\\begin{pmatrix}") + (math-compose-tex-matrix (cdr a) t) + '("\\end{pmatrix}")) + (append '(horiz "\\begin{pmatrix} ") + (math-compose-tex-matrix (cdr a) t) + '(" \\end{pmatrix}")))))) + +(put 'latex 'math-var-formatter 'math-compose-tex-var) + +(put 'latex 'math-func-formatter 'math-compose-tex-func) + +(put 'latex 'math-dots "\\ldots") + +(put 'latex 'math-big-parens '("\\left( " . " \\right)")) + +(put 'latex 'math-evalto '("\\evalto " . " \\to ")) + +(put 'latex 'math-lang-read-symbol + '((?\\ + (< math-exp-pos (1- (length math-exp-str))) + (progn + (or (string-match "\\\\hbox *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\\\text *{\\([a-zA-Z0-9]+\\)}" + math-exp-str math-exp-pos) + (string-match "\\(\\\\\\([a-zA-Z]+\\|[^a-zA-Z]\\)\\)" + math-exp-str math-exp-pos)) + (setq math-exp-token 'symbol + math-exp-pos (match-end 0) + math-expr-data (math-restore-dashes + (math-match-substring math-exp-str 1))) + (let ((code (assoc math-expr-data math-tex-ignore-words)) + envname) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + ((and (eq (nth 1 code) 'begenv) + (string-match " *{\\([^}]*\\)}" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + envname (match-string 1 math-exp-str) + math-exp-token 'punc + math-expr-data "[") + (cond ((or (string= envname "matrix") + (string= envname "bmatrix") + (string= envname "smallmatrix") + (string= envname "pmatrix")) + (if (string-match (concat "\\\\end{" envname "}") + math-exp-str math-exp-pos) + (setq math-exp-str + (replace-match "]" t t math-exp-str)) + (error "%s" (concat "No closing \\end{" envname "}")))))) + ((and (eq (nth 1 code) 'mat) + (string-match " *{" math-exp-str math-exp-pos)) + (setq math-exp-pos (match-end 0) + math-exp-token 'punc + math-expr-data "[") + (let ((right (string-match "}" math-exp-str math-exp-pos))) + (and right + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str right ?\])))))))))) + (defun math-latex-parse-frac (f val) (let (numer denom) (setq numer (car (math-read-expr-list))) @@ -560,7 +880,7 @@ (setq second (math-read-factor)) (list (nth 2 f) first second))) -(defun math-latex-print-frac (a fn) +(defun math-compose-latex-frac (a fn) (list 'horiz (nth 1 fn) "{" (math-compose-expr (nth 1 a) -1) "}{" (math-compose-expr (nth 2 a) -1) @@ -640,11 +960,162 @@ ( mu . calcFunc-moebius ) ( matrix . (math-parse-eqn-matrix) ))) +(put 'eqn 'math-special-function-table + '((intv . math-compose-eqn-intv))) + +(put 'eqn 'math-punc-table + '((?\{ . ?\() + (?\} . ?\)))) + (put 'eqn 'math-variable-table '( ( inf . var-uinf ))) (put 'eqn 'math-complex-format 'i) +(put 'eqn 'math-big-parens '("{left ( " . " right )}")) + +(put 'eqn 'math-evalto '("evalto " . " -> ")) + +(put 'eqn 'math-matrix-formatter + (function + (lambda (a) + (append '(horiz "matrix { ") + (math-compose-eqn-matrix + (cdr (math-transpose a))) + '("}"))))) + +(put 'eqn 'math-var-formatter + (function + (lambda (a prec) + (let (v) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (string-match ".'\\'" (symbol-name (nth 2 a))) + (math-compose-expr + (list 'calcFunc-Prime + (list + 'var + (intern (substring (symbol-name (nth 1 a)) 0 -1)) + (intern (substring (symbol-name (nth 2 a)) 0 -1)))) + prec) + (symbol-name (nth 1 a)))))))) + +(defconst math-eqn-special-funcs + '( calcFunc-log + calcFunc-ln calcFunc-exp + calcFunc-sin calcFunc-cos calcFunc-tan + calcFunc-sec calcFunc-csc calcFunc-cot + calcFunc-sinh calcFunc-cosh calcFunc-tanh + calcFunc-sech calcFunc-csch calcFunc-coth + calcFunc-arcsin calcFunc-arccos calcFunc-arctan + calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) + +(put 'eqn 'math-func-formatter + (function + (lambda (func a) + (let (left right) + (if (string-match "[^']'+\\'" func) + (let ((n (- (length func) (match-beginning 0) 1))) + (setq func (substring func 0 (- n))) + (while (>= (setq n (1- n)) 0) + (setq func (concat func " prime"))))) + (cond ((or (> (length a) 2) + (not (math-tex-expr-is-flat (nth 1 a)))) + (setq left "{left ( " + right " right )}")) + + ((and + (memq (car a) math-eqn-special-funcs) + (= (length a) 2) + (or (Math-realp (nth 1 a)) + (memq (car (nth 1 a)) '(var *)))) + (setq left "~{" right "}")) + (t + (setq left " ( " + right " )"))) + (list 'horiz func left + (math-compose-vector (cdr a) " , " 0) + right))))) + +(put 'eqn 'math-lang-read-symbol + '((?\" + (string-match "\\(\"\\([^\"\\]\\|\\\\.\\)*\\)\\(\"\\|\\'\\)" + math-exp-str math-exp-pos) + (progn + (setq math-exp-str (copy-sequence math-exp-str)) + (aset math-exp-str (match-beginning 1) ?\{) + (if (< (match-end 1) (length math-exp-str)) + (aset math-exp-str (match-end 1) ?\})) + (math-read-token))))) + +(defconst math-eqn-ignore-words + '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") + ("left" ("floor") ("ceil")) + ("right" ("floor") ("ceil")) + ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) + ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) + ("above" punc ","))) + +(put 'eqn 'math-lang-adjust-words + (function + (lambda () + (let ((code (assoc math-expr-data math-eqn-ignore-words))) + (cond ((null code)) + ((null (cdr code)) + (math-read-token)) + ((consp (nth 1 code)) + (math-read-token) + (if (assoc math-expr-data (cdr code)) + (setq math-expr-data (format "%s %s" + (car code) math-expr-data)))) + ((eq (nth 1 code) 'punc) + (setq math-exp-token 'punc + math-expr-data (nth 2 code))) + (t + (math-read-token) + (math-read-token))))))) + +(put 'eqn 'math-lang-read + '((eq (string-match "->\\|<-\\|+-\\|\\\\dots\\|~\\|\\^" + math-exp-str math-exp-pos) + math-exp-pos) + (progn + (setq math-exp-token 'punc + math-expr-data (math-match-substring math-exp-str 0) + math-exp-pos (match-end 0)) + (and (eq (string-match "\\\\dots\\." math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-pos (match-end 0))) + (if (memq (aref math-expr-data 0) '(?~ ?^)) + (math-read-token))))) + + +(defun math-compose-eqn-matrix (a) + (if a + (cons + (cond ((eq calc-matrix-just 'right) "rcol ") + ((eq calc-matrix-just 'center) "ccol ") + (t "lcol ")) + (cons + (list 'break math-compose-level) + (cons + "{ " + (cons + (let ((math-compose-level (1+ math-compose-level))) + (math-compose-vector (cdr (car a)) " above " 1000)) + (cons + " } " + (math-compose-eqn-matrix (cdr a))))))) + nil)) + (defun math-parse-eqn-matrix (f sym) (let ((vec nil)) (while (assoc math-expr-data '(("ccol") ("lcol") ("rcol"))) @@ -680,6 +1151,14 @@ (intern (concat (symbol-name (nth 2 x)) "'")))) (list 'calcFunc-Prime x))) +(defun math-compose-eqn-intv (a) + (list 'horiz + (if (memq (nth 1 a) '(0 1)) "(" "[") + (math-compose-expr (nth 2 a) 0) + " ... " + (math-compose-expr (nth 3 a) 0) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) + (defun calc-mathematica-language () (interactive) @@ -789,6 +1268,22 @@ (put 'math 'math-radix-formatter (function (lambda (r s) (format "%d^^%s" r s)))) +(put 'math 'math-lang-read + '((eq (string-match "\\[\\[\\|->\\|:>" math-exp-str math-exp-pos) + math-exp-pos) + (setq math-exp-token 'punc + math-expr-data (math-match-substring math-exp-str 0) + math-exp-pos (match-end 0)))) + +(put 'math 'math-compose-subscr + (function + (lambda (a) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[[" + (math-compose-expr (nth 2 a) 0) + "]]")))) + (defun math-read-math-subscr (x op) (let ((idx (math-read-expr-level 0))) (or (and (equal math-expr-data "]") @@ -862,6 +1357,9 @@ ( vectdim . calcFunc-vlen ) )) +(put 'maple 'math-special-function-table + '((intv . math-compose-maple-intv))) + (put 'maple 'math-variable-table '( ( I . var-i ) ( Pi . var-pi ) @@ -873,6 +1371,37 @@ (put 'maple 'math-complex-format 'I) +(put 'maple 'math-matrix-formatter + (function + (lambda (a) + (list 'horiz + "matrix(" + math-comp-left-bracket + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + math-comp-right-bracket + ")")))) + +(put 'maple 'math-compose-subscr + (function + (lambda (a) + (let ((args (cdr (cdr a)))) + (list 'horiz + (math-compose-expr (nth 1 a) 1000) + "[" + (math-compose-vector args ", " 0) + "]"))))) + +(add-to-list 'calc-lang-allow-underscores 'maple) +(add-to-list 'calc-lang-brackets-are-subscripts 'maple) + +(defun math-compose-maple-intv (a) + (list 'horiz + (math-compose-expr (nth 2 a) 0) + " .. " + (math-compose-expr (nth 3 a) 0))) + (defun math-read-maple-dots (x op) (list 'intv 3 x (math-read-expr-level (nth 3 op)))) diff --git a/lisp/calc/calc-macs.el b/lisp/calc/calc-macs.el index 27001b43f36..8e939cdde7b 100644 --- a/lisp/calc/calc-macs.el +++ b/lisp/calc/calc-macs.el @@ -27,6 +27,16 @@ ;;; Code: +;; Declare functions which are defined elsewhere. +(declare-function math-zerop "calc-misc" (a)) +(declare-function math-negp "calc-misc" (a)) +(declare-function math-looks-negp "calc-misc" (a)) +(declare-function math-posp "calc-misc" (a)) +(declare-function math-compare "calc-ext" (a b)) +(declare-function math-bignum "calc" (a)) +(declare-function math-compare-bignum "calc-ext" (a b)) + + (defmacro calc-wrapper (&rest body) `(calc-do (function (lambda () ,@body)))) diff --git a/lisp/calc/calc-menu.el b/lisp/calc/calc-menu.el new file mode 100644 index 00000000000..22c42adc124 --- /dev/null +++ b/lisp/calc/calc-menu.el @@ -0,0 +1,1214 @@ +;;; calc-menu.el --- a menu for Calc + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Maintainer: Jay Belanger <jay.p.belanger@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +(defvar calc-arithmetic-menu + (list "Arithmetic" + (list "Basic" + ["-(1:)" calc-change-sign :keys "n"] + ["(2:) + (1:)" calc-plus :keys "+"] + ["(2:) - (1:)" calc-minus :keys "-"] + ["(2:) * (1:)" calc-times :keys "*"] + ["(2:) / (1:)" calc-divide :keys "/"] + ["(2:) ^ (1:)" calc-power :keys "^"] + ["(2:) ^ (1/(1:))" + (progn + (require 'calc-ext) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-power))) + :keys "I ^" + :help "The (1:)th root of (2:)"] + ["abs(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :help "Absolute value"] + ["1/(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-inv)) + :keys "&"] + ["sqrt(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sqrt)) + :keys "Q"] + ["idiv(2:,1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-idiv)) + :keys "\\" + :help "The integer quotient of (2:) over (1:)"] + ["(2:) mod (1:)" + (progn + (require 'calc-misc) + (call-interactively 'calc-mod)) + :keys "%" + :help "The remainder when (2:) is divided by (1:)"]) + (list "Rounding" + ["floor(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-floor)) + :keys "F" + :help "The greatest integer less than or equal to (1:)"] + ["ceiling(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-ceiling)) + :keys "I F" + :help "The smallest integer greater than or equal to (1:)"] + ["round(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-round)) + :keys "R" + :help "The nearest integer to (1:)"] + ["truncate(1:)" + (progn + (require 'calc-arith) + (call-interactively 'calc-trunc)) + :keys "I R" + :help "The integer part of (1:)"]) + (list "Complex Numbers" + ["Re(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-re)) + :keys "f r"] + ["Im(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-im)) + :keys "f i"] + ["conj(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-conj)) + :keys "J" + :help "The complex conjugate of (1:)"] + ["length(1:)" + (progn (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :help "The length (absolute value) of (1:)"] + ["arg(1:)" + (progn + (require 'calc-cplx) + (call-interactively 'calc-argument)) + :keys "G" + :help "The argument (polar angle) of (1:)"]) + (list "Conversion" + ["Convert (1:) to a float" + (progn + (require 'calc-ext) + (call-interactively 'calc-float)) + :keys "c f"] + ["Convert (1:) to a fraction" + (progn + (require 'calc-ext) + (call-interactively 'calc-fraction)) + :keys "c F"]) + (list "Binary" + ["Set word size" + (progn + (require 'calc-bin) + (call-interactively 'calc-word-size)) + :keys "b w"] + ["Clip (1:) to word size" + (progn + (require 'calc-bin) + (call-interactively 'calc-clip)) + :keys "b c" + :help "Reduce (1:) modulo 2^wordsize"] + ["(2:) and (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-and)) + :keys "b a" + :help "Bitwise AND [modulo 2^wordsize]"] + ["(2:) or (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-or)) + :keys "b o" + :help "Bitwise inclusive OR [modulo 2^wordsize]"] + ["(2:) xor (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-xor)) + :keys "b x" + :help "Bitwise exclusive OR [modulo 2^wordsize]"] + ["diff(2:,1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-diff)) + :keys "b d" + :help "Bitwise difference [modulo 2^wordsize]"] + ["not (1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-not)) + :keys "b n" + :help "Bitwise NOT [modulo 2^wordsize]"] + ["left shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-lshift-binary)) + :keys "b l" + :help "Shift (1:)[modulo 2^wordsize] one bit left"] + ["right shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rshift-binary)) + :keys "b r" + :help "Shift (1:)[modulo 2^wordsize] one bit right, putting 0s on the left"] + ["arithmetic right shift(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rshift-arith)) + :keys "b R" + :help "Shift (1:)[modulo 2^wordsize] one bit right, duplicating the leftmost bit"] + ["rotate(1:)" + (progn + (require 'calc-bin) + (call-interactively 'calc-rotate-binary)) + :keys "b t" + :help "Rotate (1:)[modulo 2^wordsize] one bit left"]) + "-------" + ["Help on Arithmetic" + (calc-info-goto-node "Arithmetic")]) + "Menu for Calc's arithmetic functions.") + +(defvar calc-scientific-function-menu + (list "Scientific Functions" + (list "Constants" + ["pi" + (progn + (require 'calc-math) + (call-interactively 'calc-pi)) + :keys "P"] + ["e" + (progn + (require 'calc-math) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-pi))) + :keys "H P"] + ["phi" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t) + (calc-hyperbolic-flag t)) + (call-interactively 'calc-pi))) + :keys "I H P" + :help "The golden ratio"] + ["gamma" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-pi))) + :keys "I P" + :help "Euler's constant"]) + (list "Logs and Exps" + ["ln(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-ln)) + :keys "L" + :help "The natural logarithm"] + ["e^(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-exp)) + :keys "E"] + ["log(1:) [base 10]" + (progn + (require 'calc-math) + (call-interactively 'calc-log10)) + :keys "H L" + :help "The common logarithm"] + ["10^(1:)" + (progn + (require 'calc-math) + (let ((calc-inverse-flag t)) + (call-interactively 'calc-log10))) + :keys "I H L"] + ["log(2:) [base(1:)]" + (progn + (require 'calc-math) + (call-interactively 'calc-log)) + :keys "B" + :help "The logarithm with an arbitrary base"] + ["(2:) ^ (1:)" + calc-power + :keys "^"]) + (list "Trigonometric Functions" + ["sin(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sin)) + :keys "S"] + ["cos(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-cos)) + :keys "C"] + ["tan(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-tan)) + :keys "T"] + ["arcsin(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arcsin)) + :keys "I S"] + ["arccos(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arccos)) + :keys "I C"] + ["arctan(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctan)) + :keys "I T"] + ["arctan2(2:,1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctan2)) + :keys "f T"] + "--Angle Measure--" + ["Radians" + (progn + (require 'calc-math) + (calc-radians-mode)) + :keys "m r" + :style radio + :selected (eq calc-angle-mode 'rad)] + ["Degrees" + (progn + (require 'calc-math) + (calc-degrees-mode)) + :keys "m d" + :style radio + :selected (eq calc-angle-mode 'deg)] + ["HMS" + (progn + (require 'calc-math) + (calc-hms-mode)) + :keys "m h" + :style radio + :selected (eq calc-angle-mode 'hms)]) + (list "Hyperbolic Functions" + ["sinh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-sinh)) + :keys "H S"] + ["cosh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-cosh)) + :keys "H C"] + ["tanh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-tanh)) + :keys "H T"] + ["arcsinh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arcsinh)) + :keys "I H S"] + ["arccosh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arccosh)) + :keys "I H C"] + ["arctanh(1:)" + (progn + (require 'calc-math) + (call-interactively 'calc-arctanh)) + :keys "I H T"]) + (list "Advanced Math Functions" + ["Gamma(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-gamma)) + :keys "f g" + :help "The Euler Gamma function"] + ["GammaP(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-inc-gamma)) + :keys "f G" + :help "The lower incomplete Gamma function"] + ["Beta(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-beta)) + :keys "f b" + :help "The Euler Beta function"] + ["BetaI(3:,2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-inc-beta)) + :keys "f B" + :help "The incomplete Beta function"] + ["erf(1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-erf)) + :keys "f e" + :help "The error function"] + ["BesselJ(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-bessel-J)) + :keys "f j" + :help "The Bessel function of the first kind (of order (2:))"] + ["BesselY(2:,1:)" + (progn + (require 'calc-funcs) + (call-interactively 'calc-bessel-Y)) + :keys "f y" + :help "The Bessel function of the second kind (of order (2:))"]) + (list "Combinatorial Functions" + ["gcd(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-gcd)) + :keys "k g"] + ["lcm(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-lcm)) + :keys "k l"] + ["factorial(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-factorial)) + :keys "!"] + ["(2:) choose (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-choose)) + :keys "k c"] + ["permutations(2:,1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-perm)) + :keys "H k c"] + ["Primality test for (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-prime-test)) + :keys "k p" + :help "For large (1:), a probabilistic test"] + ["Factor (1:) into primes" + (progn + (require 'calc-comb) + (call-interactively 'calc-prime-factors)) + :keys "k f"] + ["Next prime after (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-next-prime)) + :keys "k n"] + ["Previous prime before (1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-prev-prime)) + :keys "I k n"] + ["phi(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-totient)) + :keys "k n" + :help "Euler's totient function"] + ["random(1:)" + (progn + (require 'calc-comb) + (call-interactively 'calc-random)) + :keys "k r" + :help "A random number >=1 and < (1:)"]) + "----" + ["Help on Scientific Functions" + (calc-info-goto-node "Scientific Functions")]) + "Menu for Calc's scientific functions.") + +(defvar calc-algebra-menu + (list "Algebra" + (list "Simplification" + ["Simplify (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-simplify)) + :keys "a s"] + ["Simplify (1:) with extended rules" + (progn + (require 'calc-alg) + (call-interactively 'calc-simplify-extended)) + :keys "a e" + :help "Apply possibly unsafe simplifications"]) + (list "Manipulation" + ["Expand formula (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-expand-formula)) + :keys "a \"" + :help "Expand (1:) into its defining formula, if possible"] + ["Evaluate variables in (1:)" + (progn + (require 'calc-ext) + (call-interactively 'calc-evaluate)) + :keys "="] + ["Make substitution in (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-substitute)) + :keys "a b" + :help + "Substitute all occurrences of a sub-expression with a new sub-expression"]) + (list "Polynomials" + ["Factor (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-factor)) + :keys "a f"] + ["Collect terms in (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-collect)) + :keys "a c" + :help "Arrange as a polynomial in a given variable"] + ["Expand (1:)" + (progn + (require 'calc-alg) + (call-interactively 'calc-expand)) + :keys "a x" + :help "Apply distributive law everywhere"] + ["Find roots of (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-poly-roots)) + :keys "a P"]) + (list "Calculus" + ["Differentiate (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-derivative)) + :keys "a d"] + ["Integrate (1:) [indefinite]" + (progn + (require 'calcalg2) + (call-interactively 'calc-integral)) + :keys "a i"] + ["Integrate (1:) [definite]" + (progn + (require 'calcalg2) + (let ((var (read-string "Integration variable: "))) + (calc-tabular-command 'calcFunc-integ "Integration" + "intg" nil var nil nil))) + :keys "C-u a i"] + ["Integrate (1:) [numeric]" + (progn + (require 'calcalg2) + (call-interactively 'calc-num-integral)) + :keys "a I" + :help "Integrate using the open Romberg method"] + ["Taylor expand (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-taylor)) + :keys "a t"] + ["Minimize (2:) [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-minimum)) + :keys "a N" + :help "Find a local minimum"] + ["Maximize (2:) [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-maximum)) + :keys "a X" + :help "Find a local maximum"]) + (list "Solving" + ["Solve equation (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-solve-for)) + :keys "a S"] + ["Solve equation (2:) numerically [initial guess = (1:)]" + (progn + (require 'calcalg3) + (call-interactively 'calc-find-root)) + :keys "a R"] + ["Find roots of polynomial (1:)" + (progn + (require 'calcalg2) + (call-interactively 'calc-poly-roots)) + :keys "a P"]) + (list "Curve Fitting" + ["Fit (1:)=[x values, y values] to a curve" + (progn + (require 'calcalg3) + (call-interactively 'calc-curve-fit)) + :keys "a F"]) + "----" + ["Help on Algebra" + (calc-info-goto-node "Algebra")]) + "Menu for Calc's algebraic facilities.") + + +(defvar calc-graphics-menu + (list "Graphics" + ["Graph 2D [(1:)= y values, (2:)= x values]" + (progn + (require 'calc-graph) + (call-interactively 'calc-graph-fast)) + :keys "g f"] + ["Graph 3D [(1:)= z values, (2:)= y values, (3:)= x values]" + (progn + (require 'calc-graph) + (call-interactively 'calc-graph-fast-3d)) + :keys "g F"] + "----" + ["Help on Graphics" + (calc-info-goto-node "Graphics")]) + "Menu for Calc's graphics.") + + +(defvar calc-vectors-menu + (list "Matrices/Vectors" + (list "Matrices" + ["(2:) + (1:)" calc-plus :keys "+"] + ["(2:) - (1:)" calc-minus :keys "-"] + ["(2:) * (1:)" calc-times :keys "*"] + ["(1:)^(-1)" + (progn + (require 'calc-arith) + (call-interactively 'calc-inv)) + :keys "&"] + ["Create an identity matrix" + (progn + (require 'calc-vec) + (call-interactively 'calc-ident)) + :keys "v i"] + ["transpose(1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-transpose)) + :keys "v t"] + ["det(1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mdet)) + :keys "V D"] + ["trace(1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mtrace)) + :keys "V T"] + ["LUD decompose (1:)" + (progn + (require 'calc-mtx) + (call-interactively 'calc-mlud)) + :keys "V L"] + ["Extract a row from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mrow)) + :keys "v r"] + ["Extract a column from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mcol)) + :keys "v c"]) + (list "Vectors" + ["Extract the first element of (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-head)) + :keys "v h"] + ["Extract an element from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-mrow)) + :keys "v r"] + ["Reverse (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-reverse-vector)) + :keys "v v"] + ["Unpack (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-unpack)) + :keys "v u" + :help "Separate the elements of (1:)"] + ["(2:) cross (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-cross)) + :keys "V C" + :help "The cross product in R^3"] + ["(2:) dot (1:)" + calc-mult + :keys "*" + :help "The dot product"] + ["Map a function across (1:)" + (progn + (require 'calc-map) + (call-interactively 'calc-map)) + :keys "V M" + :help "Apply a function to each element"]) + (list "Vectors As Sets" + ["Remove duplicates from (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-remove-duplicates)) + :keys "V +"] + ["(2:) union (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-union)) + :keys "V V"] + ["(2:) intersect (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-intersect)) + :keys "V ^"] + ["(2:) \\ (1:)" + (progn + (require 'calc-vec) + (call-interactively 'calc-set-difference)) + :keys "V -" + :help "Set difference"]) + (list "Statistics On Vectors" + ["length(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-count)) + :keys "u #" + :help "The number of data values"] + ["sum(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-sum)) + :keys "u +" + :help "The sum of the data values"] + ["max(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-max)) + :keys "u x" + :help "The maximum of the data values"] + ["min(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-min)) + :keys "u N" + :help "The minumum of the data values"] + ["mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-mean)) + :keys "u M" + :help "The average (arithmetic mean) of the data values"] + ["mean(1:) with error" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-mean-error)) + :keys "I u M" + :help "The average (arithmetic mean) of the data values as an error form"] + ["sdev(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-sdev)) + :keys "u S" + :help "The sample sdev, sqrt[sum((values - mean)^2)/(N-1)]"] + ["variance(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-variance)) + :keys "H u S" + :help "The sample variance, sum((values - mean)^2)/(N-1)"] + ["population sdev(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-pop-sdev)) + :keys "I u S" + :help "The population sdev, sqrt[sum((values - mean)^2)/N]"] + ["population variance(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-pop-variance)) + :keys "H I u S" + :help "The population variance, sum((values - mean)^2)/N"] + ["median(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-median)) + :keys "H u M" + :help "The median of the data values"] + ["harmonic mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-harmonic-mean)) + :keys "H I u M"] + ["geometric mean(1:)" + (progn + (require 'calc-stat) + (call-interactively 'calc-vector-geometric-mean)) + :keys "u G"] + ["arithmetic-geometric mean(1:)" + (progn + (require 'calc-stat) + (let ((calc-hyperbolic-flag t)) + (call-interactively 'calc-vector-geometric-mean))) + :keys "H u G"] + ["RMS(1:)" + (progn (require 'calc-arith) + (call-interactively 'calc-abs)) + :keys "A" + :help "The root-mean-square, or quadratic mean"]) + ["Abbreviate long vectors" + (progn + (require 'calc-mode) + (call-interactively 'calc-full-vectors)) + :keys "v ." + :style toggle + :selected (not calc-full-vectors)] + "----" + ["Help on Matrices/Vectors" + (calc-info-goto-node "Matrix Functions")]) + "Menu for Calc's vector and matrix functions.") + +(defvar calc-units-menu + (list "Units" + ["Convert units in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-convert-units )) + :keys "u c"] + ["Convert temperature in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-convert-temperature)) + :keys "u t"] + ["Simplify units in (1:)" + (progn + (require 'calc-units) + (call-interactively 'calc-simplify-units)) + :keys "u s"] + ["View units table" + (progn + (require 'calc-units) + (call-interactively 'calc-view-units-table)) + :keys "u V"] + "----" + ["Help on Units" + (calc-info-goto-node "Units")]) + "Menu for Calc's units functions.") + +(defvar calc-variables-menu + (list "Variables" + ["Store (1:) into a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-store)) + :keys "s s"] + ["Recall a variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-recall )) + :keys "s r"] + ["Edit the value of a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-edit-variable)) + :keys "s e"] + ["Exchange (1:) with a variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-store-exchange)) + :keys "s x"] + ["Clear variable value" + (progn + (require 'calc-store) + (call-interactively 'calc-unstore)) + :keys "s u"] + ["Evaluate variables in (1:)" + (progn + (require 'calc-ext) + (call-interactively 'calc-evaluate)) + :keys "="] + ["Evaluate (1:), assigning a value to a variable" + (progn + (require 'calc-store) + (call-interactively 'calc-let)) + :keys "s l" + :help "Evaluate (1:) under a temporary assignment of a variable"] + "----" + ["Help on Variables" + (calc-info-goto-node "Store and Recall")]) + "Menu for Calc's variables.") + +(defvar calc-stack-menu + (list "Stack" + ["Remove (1:)" + calc-pop + :keys "DEL"] + ["Switch (1:) and (2:)" + calc-roll-down + :keys "TAB"] + ["Duplicate (1:)" + calc-enter + :keys "RET"] + ["Edit (1:)" + (progn + (require 'calc-yank) + (call-interactively calc-edit)) + :keys "`"] + "----" + ["Help on Stack" + (calc-info-goto-node "Stack and Trail")]) + "Menu for Calc's stack functions.") + +(defvar calc-errors-menu + (list "Undo" + ["Undo" + (progn + (require 'calc-undo) + (call-interactively 'calc-undo)) + :keys "U"] + ["Redo" + (progn + (require 'calc-undo) + (call-interactively 'calc-redo)) + :keys "D"] + "----" + ["Help on Undo" + (progn + (calc-info-goto-node "Introduction") + (Info-goto-node "Undo"))])) + +(defvar calc-modes-menu + (list "Modes" + ["Precision" + (progn + (require 'calc-ext) + (call-interactively 'calc-precision)) + :keys "p" + :help "Set the precision for floating point calculations"] + ["Fraction mode" + (progn + (require 'calc-frac) + (call-interactively 'calc-frac-mode)) + :keys "m f" + :style toggle + :selected calc-prefer-frac + :help "Leave integer quotients as fractions"] + ["Symbolic mode" + (lambda () + (interactive) + (require 'calc-mode) + (calc-symbolic-mode nil)) + :keys "m s" + :style toggle + :selected calc-symbolic-mode + :help "Leave functions producing inexact answers in symbolic form"] + ["Infinite mode" + (lambda () + (interactive) + (require 'calc-mode) + (calc-infinite-mode nil)) + :keys "m i" + :style toggle + :selected calc-infinite-mode + :help "Let expressions like 1/0 produce infinite results"] + ["Abbreviate long vectors" + (progn + (require 'calc-mode) + (call-interactively 'calc-full-vectors)) + :keys "v ." + :style toggle + :selected (not calc-full-vectors)] + (list "Angle Measure" + ["Radians" + (progn + (require 'calc-math) + (call-interactively 'calc-radians-mode)) + :keys "m r" + :style radio + :selected (eq calc-angle-mode 'rad)] + ["Degrees" + (progn + (require 'calc-math) + (call-interactively 'calc-degrees-mode)) + :keys "m d" + :style radio + :selected (eq calc-angle-mode 'deg)] + ["HMS" + (progn + (require 'calc-math) + (call-interactively 'calc-hms-mode)) + :keys "m h" + :style radio + :selected (eq calc-angle-mode 'hms)]) + (list "Radix" + ["Decimal" + (progn + (require 'calc-bin) + (call-interactively 'calc-decimal-radix)) + :keys "d 0" + :style radio + :selected (= calc-number-radix 10)] + ["Binary" + (progn + (require 'calc-bin) + (call-interactively 'calc-binary-radix)) + :keys "d 2" + :style radio + :selected (= calc-number-radix 2)] + ["Octal" + (progn + (require 'calc-bin) + (call-interactively 'calc-octal-radix)) + :keys "d 8" + :style radio + :selected (= calc-number-radix 8)] + ["Hexadecimal" + (progn + (require 'calc-bin) + (call-interactively 'calc-hex-radix)) + :keys "d 6" + :style radio + :selected (= calc-number-radix 16)] + ["Other" + (progn + (require 'calc-bin) + (call-interactively 'calc-radix)) + :keys "d r" + :style radio + :selected (not + (or + (= calc-number-radix 10) + (= calc-number-radix 2) + (= calc-number-radix 8) + (= calc-number-radix 16)))]) + (list "Float Format" + ["Normal" + (progn + (require 'calc-mode) + (call-interactively 'calc-normal-notation)) + :keys "d n" + :style radio + :selected (eq (car-safe calc-float-format) 'float)] + ["Fixed point" + (progn + (require 'calc-mode) + (call-interactively 'calc-fix-notation)) + :keys "d f" + :style radio + :selected (eq (car-safe calc-float-format) 'fix)] + ["Scientific notation" + (progn + (require 'calc-mode) + (call-interactively 'calc-sci-notation)) + :keys "d s" + :style radio + :selected (eq (car-safe calc-float-format) 'sci)] + ["Engineering notation" + (progn + (require 'calc-mode) + (call-interactively 'calc-eng-notation)) + :keys "d e" + :style radio + :selected (eq (car-safe calc-float-format) 'eng)]) + (list "Algebraic" + ["Normal" + (progn + (require 'calc-mode) + (cond + (calc-incomplete-algebraic-mode + (calc-algebraic-mode t)) + (calc-algebraic-mode + (calc-algebraic-mode nil)))) + :style radio + :selected (not calc-algebraic-mode)] + ["Algebraic mode" + (progn + (require 'calc-mode) + (if (or + calc-incomplete-algebraic-mode + (not calc-algebraic-mode)) + (calc-algebraic-mode nil))) + :keys "m a" + :style radio + :selected (and calc-algebraic-mode + (not calc-incomplete-algebraic-mode)) + :help "Keys which start numeric entry also start algebraic entry"] + ["Incomplete algebraic mode" + (progn + (require 'calc-mode) + (unless calc-incomplete-algebraic-mode + (calc-algebraic-mode t))) + :keys "C-u m a" + :style radio + :selected calc-incomplete-algebraic-mode + :help "Only ( and [ begin algebraic entry"] + ["Total algebraic mode" + (progn + (require 'calc-mode) + (unless (eq calc-algebraic-mode 'total) + (calc-total-algebraic-mode nil))) + :keys "m t" + :style radio + :selected (eq calc-algebraic-mode 'total) + :help "All regular letters and punctuation begin algebraic entry"]) + (list "Language" + ["Normal" + (progn + (require 'calc-lang) + (call-interactively 'calc-normal-language)) + :keys "d N" + :style radio + :selected (eq calc-language nil)] + ["Big" + (progn + (require 'calc-lang) + (call-interactively 'calc-big-language)) + :keys "d B" + :style radio + :selected (eq calc-language 'big) + :help "Use textual approximations to various mathematical notations"] + ["Flat" + (progn + (require 'calc-lang) + (call-interactively 'calc-flat-language)) + :keys "d O" + :style radio + :selected (eq calc-language 'flat) + :help "Write matrices on a single line"] + ["C" + (progn + (require 'calc-lang) + (call-interactively 'calc-c-language)) + :keys "d C" + :style radio + :selected (eq calc-language 'c)] + ["Pascal" + (progn + (require 'calc-lang) + (call-interactively 'calc-pascal-language)) + :keys "d P" + :style radio + :selected (eq calc-language 'pascal)] + ["Fortran" + (progn + (require 'calc-lang) + (call-interactively 'calc-fortran-language)) + :keys "d F" + :style radio + :selected (eq calc-language 'fortran)] + ["TeX" + (progn + (require 'calc-lang) + (call-interactively 'calc-tex-language)) + :keys "d T" + :style radio + :selected (eq calc-language 'tex)] + ["LaTeX" + (progn + (require 'calc-lang) + (call-interactively 'calc-latex-language)) + :keys "d L" + :style radio + :selected (eq calc-language 'latex)] + ["Eqn" + (progn + (require 'calc-lang) + (call-interactively 'calc-eqn-language)) + :keys "d E" + :style radio + :selected (eq calc-language 'eqn)]) + "----" + ["Save mode settings" calc-save-modes :keys "m m"] + "----" + ["Help on Modes" + (calc-info-goto-node "Mode settings")]) + "Menu for Calc's mode settings.") + +(defvar calc-help-menu + (list "Help" + ["Manual" + calc-info + :keys "h i"] + ["Tutorial" + calc-tutorial + :keys "h t"] + ["Summary" + calc-info-summary + :keys "h s"] + "----" + ["Help on Help" + (progn + (calc-info-goto-node "Introduction") + (Info-goto-node "Help Commands"))]) + "Menu for Calc's help functions.") + +(defvar calc-mode-map) + +(easy-menu-define + calc-menu + calc-mode-map + "Menu for Calc." + (list "Calc" + :visible '(eq major-mode 'calc-mode) + calc-arithmetic-menu + calc-scientific-function-menu + calc-algebra-menu + calc-graphics-menu + calc-vectors-menu + calc-units-menu + calc-variables-menu + calc-stack-menu + calc-errors-menu + calc-modes-menu + calc-help-menu + ["Reset" + (progn + (require 'calc-ext) + (call-interactively 'calc-reset)) + :help "Reset Calc to its initial state"] + ["Quit" calc-quit])) + +(provide 'calc-menu) + +;; arch-tag: 9612c86a-cd4f-4baa-ab0b-40af7344d21f diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index b660e046a21..f63e0fa42f9 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -32,6 +32,35 @@ (require 'calc) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive)) +(declare-function calc-inv-hyp-prefix-help "calc-help" ()) +(declare-function calc-inverse-prefix-help "calc-help" ()) +(declare-function calc-hyperbolic-prefix-help "calc-help" ()) +(declare-function calc-explain-why "calc-stuff" (why &optional more)) +(declare-function calc-clear-command-flag "calc-ext" (f)) +(declare-function calc-roll-down-with-selections "calc-sel" (n m)) +(declare-function calc-roll-up-with-selections "calc-sel" (n m)) +(declare-function calc-last-args "calc-undo" (n)) +(declare-function calc-is-inverse "calc-ext" ()) +(declare-function calc-do-prefix-help "calc-ext" (msgs group key)) +(declare-function math-objvecp "calc-ext" (a)) +(declare-function math-known-scalarp "calc-arith" (a &optional assume-scalar)) +(declare-function math-vectorp "calc-ext" (a)) +(declare-function math-matrixp "calc-ext" (a)) +(declare-function math-trunc-special "calc-arith" (a prec)) +(declare-function math-trunc-fancy "calc-arith" (a)) +(declare-function math-floor-special "calc-arith" (a prec)) +(declare-function math-floor-fancy "calc-arith" (a)) +(declare-function math-square-matrixp "calc-ext" (a)) +(declare-function math-matrix-inv-raw "calc-mtx" (m)) +(declare-function math-known-matrixp "calc-arith" (a)) +(declare-function math-mod-fancy "calc-arith" (a b)) +(declare-function math-pow-of-zero "calc-arith" (a b)) +(declare-function math-pow-zero "calc-arith" (a b)) +(declare-function math-pow-fancy "calc-arith" (a b)) + + (defun calc-dispatch-help (arg) "C-x* is a prefix key sequence; follow it with one of these letters: diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 3d6fafc844a..d7daf1bf997 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -32,6 +32,10 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-embedded-save-original-modes "calc-embed" ()) + + (defun calc-line-numbering (n) (interactive "P") (calc-wrapper diff --git a/lisp/calc/calc-nlfit.el b/lisp/calc/calc-nlfit.el index 489599781f6..4019058a567 100644 --- a/lisp/calc/calc-nlfit.el +++ b/lisp/calc/calc-nlfit.el @@ -61,6 +61,11 @@ ;;; Code: (require 'calc-arith) +(require 'calcalg3) + +;; Declare functions which are defined elsewhere. +(declare-function calc-get-fit-variables "calcalg3" (nv nc &optional defv defc with-y homog)) +(declare-function math-map-binop "calcalg3" (binop args1 args2)) (defun math-nlfit-least-squares (xdata ydata &optional sdata sigmas) "Return the parameters A and B for the best least squares fit y=a+bx." @@ -188,7 +193,7 @@ ;;; the maximum value of q. (defun math-nlfit-find-qmax (qdata pdata tdata) - (let* ((ratios (mapcar* 'math-div pdata qdata)) + (let* ((ratios (math-map-binop 'math-div pdata qdata)) (lsdata (math-nlfit-least-squares ratios tdata)) (qmax (math-max-list (car qdata) (cdr qdata))) (a (math-neg (math-div (nth 1 lsdata) (nth 0 lsdata))))) @@ -295,7 +300,7 @@ (mat nil) (k 0)) (while (< k i) - (setq mat (cons (copy-list row) mat)) + (setq mat (cons (copy-sequence row) mat)) (setq k (1+ k))) mat)) @@ -513,7 +518,7 @@ (let* ((Ctilda (math-nlfit-make-Ctilda C lambda)) (dtilda (math-nlfit-make-dtilda d (length (car C)))) (zeta (math-nlfit-givens Ctilda dtilda)) - (newparms (mapcar* 'math-add (copy-tree parms) zeta)) + (newparms (math-map-binop 'math-add (copy-tree parms) zeta)) (newchisq (math-nlfit-chi-sq xlist ylist newparms fn slist))) (if (math-lessp newchisq chisq) (progn @@ -692,7 +697,8 @@ (nth 0 sigmacovar))) (finalparms (if sigmas - (mapcar* (lambda (x y) (list 'sdev x y)) finalparms sigmas) + (math-map-binop + (lambda (x y) (list 'sdev x y)) finalparms sigmas) finalparms)) (soln (funcall solnexpr finalparms var))) (let ((calc-fit-to-trail t) @@ -752,7 +758,7 @@ (mapcar (lambda (x) (math-get-sdev x t)) pdata) nil)) (pdata (mapcar (lambda (x) (math-get-value x)) pdata)) - (poverqdata (mapcar* 'math-div pdata qdata)) + (poverqdata (math-map-binop 'math-div pdata qdata)) (parmvals (math-nlfit-least-squares qdata poverqdata sdata sdevv)) (finalparms (list (nth 0 parmvals) (math-neg diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 4ceeeba3b42..87adf48006d 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -32,6 +32,11 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function edmacro-format-keys "edmacro" (macro &optional verbose)) +(declare-function edmacro-parse-keys "edmacro" (string &optional need-vector)) +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + (defun calc-equal-to (arg) (interactive "P") diff --git a/lisp/calc/calc-vec.el b/lisp/calc/calc-vec.el index e4b3e1e5bbc..e224e1ca6f5 100644 --- a/lisp/calc/calc-vec.el +++ b/lisp/calc/calc-vec.el @@ -32,6 +32,10 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function math-read-expr-level "calc-aent" (exp-prec &optional exp-term)) + + (defun calc-display-strings (n) (interactive "P") (calc-wrapper diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 5cfccb4f8db..69cacec2220 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -206,6 +206,84 @@ (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-set-language "calc-lang" (lang &optional option no-refresh)) +(declare-function calc-edit-finish "calc-yank" (&optional keep)) +(declare-function calc-edit-cancel "calc-yank" ()) +(declare-function calc-do-quick-calc "calc-aent" ()) +(declare-function calc-do-calc-eval "calc-aent" (str separator args)) +(declare-function calc-do-keypad "calc-keypd" (&optional full-display interactive)) +(declare-function calcFunc-unixtime "calc-forms" (date &optional zone)) +(declare-function math-parse-date "calc-forms" (math-pd-str)) +(declare-function math-lessp "calc-ext" (a b)) +(declare-function calc-embedded-finish-command "calc-embed" ()) +(declare-function calc-embedded-select-buffer "calc-embed" ()) +(declare-function calc-embedded-mode-line-change "calc-embed" ()) +(declare-function calc-push-list-in-macro "calc-prog" (vals m sels)) +(declare-function calc-replace-selections "calc-sel" (n vals m)) +(declare-function calc-record-list "calc-misc" (vals &optional prefix)) +(declare-function calc-normalize-fancy "calc-ext" (val)) +(declare-function calc-do-handle-whys "calc-misc" ()) +(declare-function calc-top-selected "calc-sel" (&optional n m)) +(declare-function calc-sel-error "calc-sel" ()) +(declare-function calc-pop-stack-in-macro "calc-prog" (n mm)) +(declare-function calc-embedded-stack-change "calc-embed" ()) +(declare-function calc-refresh-evaltos "calc-ext" (&optional which-var)) +(declare-function calc-do-refresh "calc-misc" ()) +(declare-function calc-binary-op-fancy "calc-ext" (name func arg ident unary)) +(declare-function calc-unary-op-fancy "calc-ext" (name func arg)) +(declare-function calc-delete-selection "calc-sel" (n)) +(declare-function calc-alg-digit-entry "calc-aent" ()) +(declare-function calc-alg-entry "calc-aent" (&optional initial prompt)) +(declare-function calc-dots "calc-incom" ()) +(declare-function calc-temp-minibuffer-message "calc-misc" (m)) +(declare-function math-read-radix-digit "calc-misc" (dig)) +(declare-function calc-digit-dots "calc-incom" ()) +(declare-function math-normalize-fancy "calc-ext" (a)) +(declare-function math-normalize-nonstandard "calc-ext" ()) +(declare-function math-recompile-eval-rules "calc-alg" ()) +(declare-function math-apply-rewrites "calc-rewr" (expr rules &optional heads math-apply-rw-ruleset)) +(declare-function calc-record-why "calc-misc" (&rest stuff)) +(declare-function math-dimension-error "calc-vec" ()) +(declare-function calc-incomplete-error "calc-incom" (a)) +(declare-function math-float-fancy "calc-arith" (a)) +(declare-function math-neg-fancy "calc-arith" (a)) +(declare-function math-zerop "calc-misc" (a)) +(declare-function calc-add-fractions "calc-frac" (a b)) +(declare-function math-add-objects-fancy "calc-arith" (a b)) +(declare-function math-add-symb-fancy "calc-arith" (a b)) +(declare-function math-mul-zero "calc-arith" (a b)) +(declare-function calc-mul-fractions "calc-frac" (a b)) +(declare-function math-mul-objects-fancy "calc-arith" (a b)) +(declare-function math-mul-symb-fancy "calc-arith" (a b)) +(declare-function math-reject-arg "calc-misc" (&optional a p option)) +(declare-function math-div-by-zero "calc-arith" (a b)) +(declare-function math-div-zero "calc-arith" (a b)) +(declare-function math-make-frac "calc-frac" (num den)) +(declare-function calc-div-fractions "calc-frac" (a b)) +(declare-function math-div-objects-fancy "calc-arith" (a b)) +(declare-function math-div-symb-fancy "calc-arith" (a b)) +(declare-function math-compose-expr "calccomp" (a prec)) +(declare-function math-comp-width "calccomp" (c)) +(declare-function math-composition-to-string "calccomp" (c &optional width)) +(declare-function math-stack-value-offset-fancy "calccomp" ()) +(declare-function math-format-flat-expr-fancy "calc-ext" (a prec)) +(declare-function math-adjust-fraction "calc-ext" (a)) +(declare-function math-format-binary "calc-bin" (a)) +(declare-function math-format-radix "calc-bin" (a)) +(declare-function math-group-float "calc-ext" (str)) +(declare-function math-mod "calc-misc" (a b)) +(declare-function math-format-number-fancy "calc-ext" (a prec)) +(declare-function math-format-bignum-fancy "calc-ext" (a)) +(declare-function math-read-number-fancy "calc-ext" (s)) +(declare-function calc-do-grab-region "calc-yank" (top bot arg)) +(declare-function calc-do-grab-rectangle "calc-yank" (top bot arg &optional reduce)) +(declare-function calc-do-embedded "calc-embed" (calc-embed-arg end obeg oend)) +(declare-function calc-do-embedded-activate "calc-embed" (calc-embed-arg cbuf)) +(declare-function math-do-defmath "calc-prog" (func args body)) +(declare-function calc-load-everything "calc-ext" ()) + + (defgroup calc nil "GNU Calc." :prefix "calc-" @@ -889,6 +967,16 @@ If nil, selections displayed but ignored.") "Function through which to pass strings before parsing.") (defvar calc-radix-formatter nil "Formatting function used for non-decimal numbers.") +(defvar calc-lang-slash-idiv nil + "A list of languages in which / might represent integer division.") +(defvar calc-lang-allow-underscores nil + "A list of languages which allow underscores in variable names.") +(defvar calc-lang-c-type-hex nil + "Languages in which octal and hex numbers are written with leading 0 and 0x,") +(defvar calc-lang-brackets-are-subscripts nil + "Languages in which subscripts are indicated by brackets.") +(defvar calc-lang-parens-are-subscripts nil + "Languages in which subscripts are indicated by parentheses.") (defvar calc-last-kill nil) ; Last number killed in calc-mode. (defvar calc-dollar-values nil) ; Values to be used for '$'. @@ -911,7 +999,6 @@ If nil, selections displayed but ignored.") (defvar math-eval-rules-cache-tag t) (defvar math-radix-explicit-format t) (defvar math-expr-function-mapping nil) -(defvar math-expr-special-function-mapping nil) (defvar math-expr-variable-mapping nil) (defvar math-read-expr-quotes nil) (defvar math-working-step nil) @@ -1009,6 +1096,7 @@ If nil, selections displayed but ignored.") (if calc-scan-for-dels (append (where-is-internal 'delete-backward-char global-map) (where-is-internal 'backward-delete-char global-map) + (where-is-internal 'backward-delete-char-untabify global-map) '("\C-d")) '("\177" "\C-d"))) @@ -1221,6 +1309,7 @@ Notations: 3.14e6 3.14 * 10^6 (string-match "full" (nth 1 p)) (setq calc-standalone-flag t)) (setq p (cdr p)))) + (require 'calc-menu) (run-mode-hooks 'calc-mode-hook) (calc-refresh t) (calc-set-mode-line) @@ -3497,34 +3586,6 @@ and all digits are kept, regardless of Calc's current precision." (math-read-bignum (substring s 0 (- math-bignum-digit-length)))) (list (string-to-number s)))) - -(defconst math-tex-ignore-words - '( ("\\hbox") ("\\mbox") ("\\text") ("\\left") ("\\right") - ("\\,") ("\\>") ("\\:") ("\\;") ("\\!") ("\\ ") - ("\\quad") ("\\qquad") ("\\hfil") ("\\hfill") - ("\\displaystyle") ("\\textstyle") ("\\dsize") ("\\tsize") - ("\\scriptstyle") ("\\scriptscriptstyle") ("\\ssize") ("\\sssize") - ("\\rm") ("\\bf") ("\\it") ("\\sl") - ("\\roman") ("\\bold") ("\\italic") ("\\slanted") - ("\\cal") ("\\mit") ("\\Cal") ("\\Bbb") ("\\frak") ("\\goth") - ("\\evalto") - ("\\matrix" mat) ("\\bmatrix" mat) ("\\pmatrix" mat) - ("\\begin" begenv) - ("\\cr" punc ";") ("\\\\" punc ";") ("\\*" punc "*") - ("\\{" punc "[") ("\\}" punc "]"))) - -(defconst math-latex-ignore-words - (append math-tex-ignore-words - '(("\\begin" begenv)))) - -(defconst math-eqn-ignore-words - '( ("roman") ("bold") ("italic") ("mark") ("lineup") ("evalto") - ("left" ("floor") ("ceil")) - ("right" ("floor") ("ceil")) - ("arc" ("sin") ("cos") ("tan") ("sinh") ("cosh") ("tanh")) - ("size" n) ("font" n) ("fwd" n) ("back" n) ("up" n) ("down" n) - ("above" punc ","))) - (defconst math-standard-opers '( ( "_" calcFunc-subscr 1200 1201 ) ( "%" calcFunc-percent 1100 -1 ) diff --git a/lisp/calc/calcalg3.el b/lisp/calc/calcalg3.el index 5aa410be19e..374b0487cfe 100644 --- a/lisp/calc/calcalg3.el +++ b/lisp/calc/calcalg3.el @@ -32,6 +32,24 @@ (require 'calc-ext) (require 'calc-macs) +;; Declare functions which are defined elsewhere. +(declare-function calc-fit-s-shaped-logistic-curve "calc-nlfit" (arg)) +(declare-function calc-fit-bell-shaped-logistic-curve "calc-nlfit" (arg)) +(declare-function calc-fit-hubbert-linear-curve "calc-nlfit" (&optional sdv)) +(declare-function calc-graph-add-curve "calc-graph" (xdata ydata &optional zdata)) +(declare-function calc-graph-lookup "calc-graph" (thing)) +(declare-function calc-graph-set-styles "calc-graph" (lines points &optional yerr)) +(declare-function math-min-list "calc-arith" (a b)) +(declare-function math-max-list "calc-arith" (a b)) + + +(defun math-map-binop (binop args1 args2) + "Apply BINOP to the elements of the lists ARGS1 and ARGS2" + (if args1 + (cons + (funcall binop (car args1) (car args2)) + (funcall 'math-map-binop binop (cdr args1) (cdr args2))))) + (defun calc-find-root (var) (interactive "sVariable(s) to solve for: ") (calc-slow-wrapper @@ -239,9 +257,9 @@ (nth 1 plot) (cons 'vec - (mapcar* 'calcFunc-div - (cdr (nth 2 plot)) - (cdr (nth 1 plot))))))) + (math-map-binop 'calcFunc-div + (cdr (nth 2 plot)) + (cdr (nth 1 plot))))))) (calc-fit-hubbert-linear-curve func)) ((memq key '(?e ?E)) (calc-get-fit-variables calc-curve-nvars diff --git a/lisp/calc/calccomp.el b/lisp/calc/calccomp.el index 6bd663cef5b..dd59b366881 100644 --- a/lisp/calc/calccomp.el +++ b/lisp/calc/calccomp.el @@ -32,16 +32,6 @@ (require 'calc-ext) (require 'calc-macs) -(defconst math-eqn-special-funcs - '( calcFunc-log - calcFunc-ln calcFunc-exp - calcFunc-sin calcFunc-cos calcFunc-tan - calcFunc-sec calcFunc-csc calcFunc-cot - calcFunc-sinh calcFunc-cosh calcFunc-tanh - calcFunc-sech calcFunc-csch calcFunc-coth - calcFunc-arcsin calcFunc-arccos calcFunc-arctan - calcFunc-arcsinh calcFunc-arccosh calcFunc-arctanh)) - ;;; A "composition" has one of the following forms: ;;; ;;; "string" A literal string @@ -80,6 +70,21 @@ (defvar math-comp-right-bracket) (defvar math-comp-comma) +(defun math-compose-var (a) + (let (v) + (if (and math-compose-hash-args + (let ((p calc-arg-values)) + (setq v 1) + (while (and p (not (equal (car p) a))) + (setq p (and (eq math-compose-hash-args t) (cdr p)) + v (1+ v))) + p)) + (if (eq math-compose-hash-args 1) + "#" + (format "#%d" v)) + (if (memq calc-language calc-lang-allow-underscores) + (math-to-underscores (symbol-name (nth 1 a))) + (symbol-name (nth 1 a)))))) (defun math-compose-expr (a prec) (let ((math-compose-level (1+ math-compose-level)) @@ -94,17 +99,24 @@ (list 'tag a (math-compose-expr a prec)))) ((and (not (consp a)) (not (integerp a))) (concat "'" (prin1-to-string a))) - ((setq spfn (assq (car-safe a) math-expr-special-function-mapping)) + ((setq spfn (assq (car-safe a) + (get calc-language 'math-special-function-table))) (setq spfn (cdr spfn)) - (funcall (car spfn) a spfn)) + (if (consp spfn) + (funcall (car spfn) a spfn) + (funcall spfn a))) ((math-scalarp a) (if (or (eq (car-safe a) 'frac) (and (nth 1 calc-frac-format) (Math-integerp a))) - (if (memq calc-language '(tex latex eqn math maple c fortran pascal)) + (if (and + calc-language + (not (memq calc-language + '(flat big unform)))) (let ((aa (math-adjust-fraction a)) (calc-frac-format nil)) (math-compose-expr (list '/ - (if (memq calc-language '(c fortran)) + (if (memq calc-language + calc-lang-slash-idiv) (math-float (nth 1 aa)) (nth 1 aa)) (nth 2 aa)) prec)) @@ -268,59 +280,25 @@ (cdr a) (if full rows 3) t))))) (if (or calc-full-vectors (< (length a) 7)) - (if (and (eq calc-language 'tex) - (math-matrixp a)) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\matrix{") - (math-compose-tex-matrix (cdr a)) - '("}")) - (append '(horiz "\\matrix{ ") - (math-compose-tex-matrix (cdr a)) - '(" }"))) - (if (and (eq calc-language 'latex) - (math-matrixp a)) - (if (and (integerp calc-language-option) - (or (= calc-language-option 0) - (> calc-language-option 1) - (< calc-language-option -1))) - (append '(vleft 0 "\\begin{pmatrix}") - (math-compose-tex-matrix (cdr a) t) - '("\\end{pmatrix}")) - (append '(horiz "\\begin{pmatrix} ") - (math-compose-tex-matrix (cdr a) t) - '(" \\end{pmatrix}"))) - (if (and (eq calc-language 'eqn) - (math-matrixp a)) - (append '(horiz "matrix { ") - (math-compose-eqn-matrix - (cdr (math-transpose a))) - '("}")) - (if (and (eq calc-language 'maple) - (math-matrixp a)) - (list 'horiz - "matrix(" - math-comp-left-bracket - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - math-comp-right-bracket - ")") - (list 'horiz - math-comp-left-bracket - (math-compose-vector (cdr a) - (concat math-comp-comma " ") - math-comp-vector-prec) - math-comp-right-bracket))))) + (if (and + (setq spfn (get calc-language 'math-matrix-formatter)) + (math-matrixp a)) + (funcall spfn a) + (list 'horiz + math-comp-left-bracket + (math-compose-vector (cdr a) + (concat math-comp-comma " ") + math-comp-vector-prec) + math-comp-right-bracket)) (list 'horiz math-comp-left-bracket (math-compose-vector (list (nth 1 a) (nth 2 a) (nth 3 a)) (concat math-comp-comma " ") math-comp-vector-prec) - math-comp-comma (if (memq calc-language '(tex latex)) - " \\ldots" " ...") + math-comp-comma + (if (setq spfn (get calc-language 'math-dots)) + (concat " " spfn) + " ...") math-comp-comma " " (list 'break math-compose-level) (math-compose-expr (nth (1- (length a)) a) @@ -354,62 +332,23 @@ (let ((v (rassq (nth 2 a) math-expr-variable-mapping))) (if v (symbol-name (car v)) - (if (and (memq calc-language '(tex latex)) - calc-language-option - (not (= calc-language-option 0)) - (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" - (symbol-name (nth 1 a)))) - (if (eq calc-language 'latex) - (format "\\text{%s}" (symbol-name (nth 1 a))) - (format "\\hbox{%s}" (symbol-name (nth 1 a)))) - (if (and math-compose-hash-args - (let ((p calc-arg-values)) - (setq v 1) - (while (and p (not (equal (car p) a))) - (setq p (and (eq math-compose-hash-args t) (cdr p)) - v (1+ v))) - p)) - (if (eq math-compose-hash-args 1) - "#" - (format "#%d" v)) - (if (memq calc-language '(c fortran pascal maple)) - (math-to-underscores (symbol-name (nth 1 a))) - (if (and (eq calc-language 'eqn) - (string-match ".'\\'" (symbol-name (nth 2 a)))) - (math-compose-expr - (list 'calcFunc-Prime - (list - 'var - (intern (substring (symbol-name (nth 1 a)) 0 -1)) - (intern (substring (symbol-name (nth 2 a)) 0 -1)))) - prec) - (symbol-name (nth 1 a))))))))) + (if (setq spfn (get calc-language 'math-var-formatter)) + (funcall spfn a prec) + (math-compose-var a))))) ((eq (car a) 'intv) (list 'horiz - (if (eq calc-language 'maple) "" - (if (memq (nth 1 a) '(0 1)) "(" "[")) + (if (memq (nth 1 a) '(0 1)) "(" "[") (math-compose-expr (nth 2 a) 0) - (if (memq calc-language '(tex latex)) " \\ldots " - (if (eq calc-language 'eqn) " ... " " .. ")) + " .. " (math-compose-expr (nth 3 a) 0) - (if (eq calc-language 'maple) "" - (if (memq (nth 1 a) '(0 2)) ")" "]")))) + (if (memq (nth 1 a) '(0 2)) ")" "]"))) ((eq (car a) 'date) (if (eq (car calc-date-format) 'X) (math-format-date a) (concat "<" (math-format-date a) ">"))) - ((and (eq (car a) 'calcFunc-subscr) (cdr (cdr a)) - (memq calc-language '(c pascal fortran maple))) - (let ((args (cdr (cdr a)))) - (while (and (memq calc-language '(pascal fortran)) - (eq (car-safe (nth 1 a)) 'calcFunc-subscr)) - (setq args (append (cdr (cdr (nth 1 a))) args) - a (nth 1 a))) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - (if (eq calc-language 'fortran) "(" "[") - (math-compose-vector args ", " 0) - (if (eq calc-language 'fortran) ")" "]")))) + ((and (eq (car a) 'calcFunc-subscr) + (setq spfn (get calc-language 'math-compose-subscr))) + (funcall spfn a)) ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) (eq calc-language 'big)) (let* ((a1 (math-compose-expr (nth 1 a) 1000)) @@ -426,25 +365,6 @@ ", " a2)) (list 'subscr a1 a2)))) - ((and (eq (car a) 'calcFunc-subscr) (= (length a) 3) - (eq calc-language 'math)) - (list 'horiz - (math-compose-expr (nth 1 a) 1000) - "[[" - (math-compose-expr (nth 2 a) 0) - "]]")) - ((and (eq (car a) 'calcFunc-sqrt) - (memq calc-language '(tex latex))) - (list 'horiz - "\\sqrt{" - (math-compose-expr (nth 1 a) 0) - "}")) - ((and nil (eq (car a) 'calcFunc-sqrt) - (eq calc-language 'eqn)) - (list 'horiz - "sqrt {" - (math-compose-expr (nth 1 a) -1) - "}")) ((and (eq (car a) '^) (eq calc-language 'big)) (list 'supscr @@ -469,14 +389,6 @@ (list 'vcent (math-comp-height a1) a1 '(rule ?-) a2))) - ((and (memq (car a) '(calcFunc-sum calcFunc-prod)) - (memq calc-language '(tex latex)) - (= (length a) 5)) - (list 'horiz (if (eq (car a) 'calcFunc-sum) "\\sum" "\\prod") - "_{" (math-compose-expr (nth 2 a) 0) - "=" (math-compose-expr (nth 3 a) 0) - "}^{" (math-compose-expr (nth 4 a) 0) - "}{" (math-compose-expr (nth 1 a) 0) "}")) ((and (eq (car a) 'calcFunc-lambda) (> (length a) 2) (memq calc-language '(nil flat big))) @@ -525,11 +437,9 @@ (integerp (nth 2 a))) (let ((c (math-compose-expr (nth 1 a) -1))) (if (> prec (nth 2 a)) - (if (memq calc-language '(tex latex)) - (list 'horiz "\\left( " c " \\right)") - (if (eq calc-language 'eqn) - (list 'horiz "{left ( " c " right )}") - (list 'horiz "(" c ")"))) + (if (setq spfn (get calc-language 'math-big-parens)) + (list 'horiz (car spfn) c (cdr spfn)) + (list 'horiz "(" c ")")) c))) ((and (eq (car a) 'calcFunc-choriz) (not (eq calc-language 'unform)) @@ -663,13 +573,13 @@ (make-list (nth 1 a) c)))))) ((and (eq (car a) 'calcFunc-evalto) (setq calc-any-evaltos t) - (memq calc-language '(tex latex eqn)) + (setq spfn (get calc-language 'math-evalto)) (= math-compose-level (if math-comp-tagged 2 1)) (= (length a) 3)) (list 'horiz - (if (memq calc-language '(tex latex)) "\\evalto " "evalto ") + (car spfn) (math-compose-expr (nth 1 a) 0) - (if (memq calc-language '(tex latex)) " \\to " " -> ") + (cdr spfn) (math-compose-expr (nth 2 a) 0))) (t (let ((op (and (not (eq calc-language 'unform)) @@ -895,56 +805,14 @@ (symbol-name func)) (math-match-substring (symbol-name func) 1) (symbol-name func)))) - (if (memq calc-language '(c fortran pascal maple)) + (if (memq calc-language calc-lang-allow-underscores) (setq func (math-to-underscores func))) - (if (and (memq calc-language '(tex latex)) - calc-language-option - (not (= calc-language-option 0)) - (string-match "\\`[a-zA-Z][a-zA-Z0-9]+\\'" func)) - (if (< (prefix-numeric-value calc-language-option) 0) - (setq func (format "\\%s" func)) - (setq func (if (eq calc-language 'latex) - (format "\\text{%s}" func) - (format "\\hbox{%s}" func))))) - (if (and (eq calc-language 'eqn) - (string-match "[^']'+\\'" func)) - (let ((n (- (length func) (match-beginning 0) 1))) - (setq func (substring func 0 (- n))) - (while (>= (setq n (1- n)) 0) - (setq func (concat func " prime"))))) - (cond ((and (memq calc-language '(tex latex)) - (or (> (length a) 2) - (not (math-tex-expr-is-flat (nth 1 a))))) - (setq left "\\left( " - right " \\right)")) - ((and (eq calc-language 'eqn) - (or (> (length a) 2) - (not (math-tex-expr-is-flat (nth 1 a))))) - (setq left "{left ( " - right " right )}")) - ((and (or (and (memq calc-language '(tex latex)) - (eq (aref func 0) ?\\)) - (and (eq calc-language 'eqn) - (memq (car a) math-eqn-special-funcs))) - (not (or - (string-match "\\hbox{" func) - (string-match "\\text{" func))) - (= (length a) 2) - (or (Math-realp (nth 1 a)) - (memq (car (nth 1 a)) '(var *)))) - (setq left (if (eq calc-language 'eqn) "~{" "{") - right "}")) - ((eq calc-language 'eqn) - (setq left " ( " - right " )")) - (t (setq left calc-function-open - right calc-function-close))) - (list 'horiz func left - (math-compose-vector (cdr a) - (if (eq calc-language 'eqn) - " , " ", ") - 0) - right))))))))) + (if (setq spfn (get calc-language 'math-func-formatter)) + (funcall spfn func a) + + (list 'horiz func calc-function-open + (math-compose-vector (cdr a) ", " 0) + calc-function-close)))))))))) (defun math-prod-first-term (x) @@ -1003,8 +871,12 @@ (if (<= count 0) (if (< count 0) (math-compose-rows (cdr a) -1 nil) - (cons (concat (if (memq calc-language '(tex latex)) " \\ldots" " ...") - math-comp-comma) + (cons (concat + (let ((mdots (get calc-language 'math-dots))) + (if mdots + (concat " " mdots) + " ...")) + math-comp-comma) (math-compose-rows (cdr a) -1 nil))) (cons (list 'horiz (if first (concat math-comp-left-bracket " ") " ") @@ -1016,31 +888,6 @@ (math-compose-expr (car a) math-comp-vector-prec) (concat " " math-comp-right-bracket))))) -(defun math-compose-tex-matrix (a &optional ltx) - (if (cdr a) - (cons (append (math-compose-vector (cdr (car a)) " & " 0) - (if ltx '(" \\\\ ") '(" \\cr "))) - (math-compose-tex-matrix (cdr a) ltx)) - (list (math-compose-vector (cdr (car a)) " & " 0)))) - -(defun math-compose-eqn-matrix (a) - (if a - (cons - (cond ((eq calc-matrix-just 'right) "rcol ") - ((eq calc-matrix-just 'center) "ccol ") - (t "lcol ")) - (cons - (list 'break math-compose-level) - (cons - "{ " - (cons - (let ((math-compose-level (1+ math-compose-level))) - (math-compose-vector (cdr (car a)) " above " 1000)) - (cons - " } " - (math-compose-eqn-matrix (cdr a))))))) - nil)) - (defun math-vector-is-string (a) (while (and (setq a (cdr a)) (or (and (natnump (car a)) diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el index 94df068b012..c605cbef10d 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -82,7 +82,7 @@ ;;;###autoload (defcustom appt-issue-message t - "*Non-nil means check for appointments in the diary buffer. + "Non-nil means check for appointments in the diary buffer. To be detected, the diary entry must have the format described in the documentation of the function `appt-check'." :type 'boolean @@ -94,19 +94,19 @@ variable `appt-display-format' instead." "22.1") ;;;###autoload (defcustom appt-message-warning-time 12 - "*Time in minutes before an appointment that the warning begins." + "Time in minutes before an appointment that the warning begins." :type 'integer :group 'appt) ;;;###autoload (defcustom appt-audible t - "*Non-nil means beep to indicate appointment." + "Non-nil means beep to indicate appointment." :type 'boolean :group 'appt) ;;;###autoload (defcustom appt-visible t - "*Non-nil means display appointment message in echo area. + "Non-nil means display appointment message in echo area. This variable is only relevant if `appt-msg-window' is nil." :type 'boolean :group 'appt) @@ -115,7 +115,7 @@ This variable is only relevant if `appt-msg-window' is nil." ;;;###autoload (defcustom appt-msg-window t - "*Non-nil means display appointment message in another window. + "Non-nil means display appointment message in another window. If non-nil, this variable overrides `appt-visible'." :type 'boolean :group 'appt) @@ -144,27 +144,27 @@ of the (obsolete) variables `appt-msg-window' and `appt-visible'." ;;;###autoload (defcustom appt-display-mode-line t - "*Non-nil means display minutes to appointment and time on the mode line. + "Non-nil means display minutes to appointment and time on the mode line. This is in addition to any other display of appointment messages." :type 'boolean :group 'appt) ;;;###autoload (defcustom appt-display-duration 10 - "*The number of seconds an appointment message is displayed. + "The number of seconds an appointment message is displayed. Only relevant if reminders are to be displayed in their own window." :type 'integer :group 'appt) ;;;###autoload (defcustom appt-display-diary t - "*Non-nil displays the diary when the appointment list is first initialized. + "Non-nil displays the diary when the appointment list is first initialized. This will occur at midnight when the appointment list is updated." :type 'boolean :group 'appt) (defcustom appt-display-interval 3 - "*Number of minutes to wait between checking the appointment list." + "Number of minutes to wait between checking the appointment list." :type 'integer :group 'appt) @@ -436,20 +436,13 @@ displayed in a window: "Display appointment message APPT-MSG in a separate buffer. The appointment is due in MIN-TO-APP (a string) minutes. NEW-TIME is a string giving the date." - (require 'electric) - - ;; Make sure we're not in the minibuffer - ;; before splitting the window. - - (if (equal (selected-window) (minibuffer-window)) - (if (other-window 1) - (select-window (other-window 1)) - (if (display-multi-frame-p) - (select-frame (other-frame 1))))) - + ;; Make sure we're not in the minibuffer before splitting the window. + ;; FIXME this seems needlessly complicated? + (when (minibufferp) + (other-window 1) + (and (minibufferp) (display-multi-frame-p) (other-frame 1))) (let ((this-window (selected-window)) (appt-disp-buf (set-buffer (get-buffer-create appt-buffer-name)))) - (if (cdr (assq 'unsplittable (frame-parameters))) ;; In an unsplittable frame, use something somewhere else. (display-buffer appt-disp-buf) @@ -489,7 +482,7 @@ Usually just deletes the appointment buffer." (let ((next-bottom-edge (nth 3 (window-edges w)))) (when (< bottom-edge next-bottom-edge) (setq bottom-edge next-bottom-edge - lowest-window w))))) + lowest-window w)))) 'nomini) (select-window lowest-window))) (defconst appt-time-regexp diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index dae539b3436..f6d5cdb58c1 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -204,6 +204,10 @@ nil if it is not visible in the current calendar window." (if (calendar-date-is-visible-p date) (list (list date string)))))))) +;; d-b-l-e should be called from diary code. +(declare-function add-to-diary-list "diary-lib" + (date string specifier &optional marker globcolor literal)) + (defun diary-bahai-list-entries () "Add any Bahá'à date entries from the diary file to `diary-entries-list'. Bahá'à date diary entries must be prefaced by an @@ -290,6 +294,12 @@ calendar. This function is provided for use with the (set-buffer-modified-p diary-modified)) (goto-char (point-min)))) +(declare-function diary-name-pattern "diary-lib" + (string-array &optional abbrev-array paren)) + +(declare-function mark-calendar-days-named "diary-lib" + (dayname &optional color)) + (defun diary-bahai-mark-entries () "Mark days in the calendar window that have Bahá'à date diary entries. Each entry in diary-file (or included files) visible in the calendar diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 02cc9bfabb2..9e20bfa8802 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -301,6 +301,9 @@ nil if it is not visible in the current calendar window." (if (calendar-date-is-visible-p date) (list (list date string)))))))) +;; h-r-h-e should be called from holidays code. +(declare-function holiday-filter-visible-calendar "holidays" (l)) + (defun holiday-rosh-hashanah-etc () "List of dates related to Rosh Hashanah, as visible in calendar window." (if (or (< displayed-month 8) @@ -500,6 +503,10 @@ nil if it is not visible in the current calendar window." (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) "Shabbat Nahamu")))))) +;; l-h-d-e should be called from diary code. +(declare-function add-to-diary-list "diary-lib" + (date string specifier &optional marker globcolor literal)) + (defun list-hebrew-diary-entries () "Add any Hebrew date entries from the diary file to `diary-entries-list'. Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' @@ -661,6 +668,12 @@ A value of 0 in any position is a wildcard." (mark-visible-calendar-date (calendar-gregorian-from-absolute date))))))))) +(declare-function diary-name-pattern "diary-lib" + (string-array &optional abbrev-array paren)) + +(declare-function mark-calendar-days-named "diary-lib" + (dayname &optional color)) + (defun mark-hebrew-diary-entries () "Mark days in the calendar window that have Hebrew date diary entries. Each entry in diary-file (or included files) visible in the calendar window diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index c562437fc14..aa8590340e0 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -195,6 +195,10 @@ nil if it is not visible in the current calendar window." (if (calendar-date-is-visible-p date) (list (list date string)))))))) +;; l-i-d-e should be called from diary code. +(declare-function add-to-diary-list "diary-lib" + (date string specifier &optional marker globcolor literal)) + (defun list-islamic-diary-entries () "Add any Islamic date entries from the diary file to `diary-entries-list'. Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' @@ -281,6 +285,12 @@ not be marked in the calendar. This function is provided for use with the (set-buffer-modified-p diary-modified)) (goto-char (point-min)))) +(declare-function diary-name-pattern "diary-lib" + (string-array &optional abbrev-array paren)) + +(declare-function mark-calendar-days-named "diary-lib" + (dayname &optional color)) + (defun mark-islamic-diary-entries () "Mark days in the calendar window that have Islamic date diary entries. Each entry in diary-file (or included files) visible in the calendar window diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index 47fd4fc4c2a..0f54722a5ca 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -33,6 +33,53 @@ ;;; Code: +;; The code in this file is only called from calendar.el, but can't +;; require it (to supress undefined function warnings from compiler) +;; without a recursive require. +;; All these functions are either autoloaded, or autoloaded or defined +;; in calendar.el. +(declare-function calendar-increment-month "calendar" (n &optional mon yr)) +(declare-function calendar-month-name "calendar" (month &optional abbrev)) +(declare-function extract-calendar-year "calendar" (date)) +(declare-function calendar-cursor-to-date "calendar" (&optional error)) +(declare-function holiday-list "holidays" (y1 y2 &optional l label)) +(declare-function calendar-sunrise-sunset "solar" nil) +(declare-function calendar-current-date "calendar" nil) +(declare-function calendar-cursor-holidays "holidays" nil) +(declare-function calendar-date-string "calendar" + (date &optional abbreviate nodayname)) +(declare-function insert-diary-entry "diary-lib" (arg)) +(declare-function calendar-set-mark "calendar" (arg)) +(declare-function cal-tex-cursor-day "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-week "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-week2 "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-week-iso "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-week-monday "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-filofax-daily "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-filofax-2week "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-filofax-week "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-month "cal-tex" (arg)) +(declare-function cal-tex-cursor-month-landscape "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-year "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-filofax-year "cal-tex" (&optional arg)) +(declare-function cal-tex-cursor-year-landscape "cal-tex" (&optional arg)) +(declare-function calendar-day-of-year-string "calendar" (&optional date)) +(declare-function calendar-iso-date-string "cal-iso" (&optional date)) +(declare-function calendar-julian-date-string "cal-julian" (&optional date)) +(declare-function calendar-astro-date-string "cal-julian" (&optional date)) +(declare-function calendar-absolute-from-gregorian "calendar" (date)) +(declare-function calendar-hebrew-date-string "cal-hebrew" (&optional date)) +(declare-function calendar-persian-date-string "cal-persia" (&optional date)) +(declare-function calendar-bahai-date-string "cal-bahai" (&optional date)) +(declare-function calendar-islamic-date-string "cal-islam" (&optional date)) +(declare-function calendar-chinese-date-string "cal-china" (&optional date)) +(declare-function calendar-coptic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-ethiopic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-french-date-string "cal-french" (&optional date)) +(declare-function calendar-mayan-date-string "cal-mayan" (&optional date)) +(declare-function calendar-print-chinese-date "cal-china" nil) +(declare-function calendar-goto-date "cal-move" (date)) + (defvar displayed-year) (defconst cal-menu-moon-menu @@ -94,12 +141,15 @@ "--" ,@(let ((l ())) ;; Show 11 years--5 before, 5 after year of middle month. + ;; http://lists.gnu.org/archive/html/emacs-devel/2007-11/msg01813.html (dotimes (i 11) - (push (vector "For Year" + (push (vector (format "hol-year-%d" i) `(lambda () (interactive) - (holiday-list (+ displayed-year ,(- i 5)))) - :suffix `(number-to-string (+ displayed-year ,(- i 5)))) + (holiday-list (+ displayed-year ,(- i 5)) + (+ displayed-year ,(- i 5)))) + :label `(format "For Year %d" + (+ displayed-year ,(- i 5)))) l)) (nreverse l)) "--" diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el index 24b1f896179..4aea547f88d 100644 --- a/lisp/calendar/cal-x.el +++ b/lisp/calendar/cal-x.el @@ -64,6 +64,9 @@ Location and color should be set in .Xdefaults.") "Hooks to be run just after setting up a calendar frame. Can be used to change frame parameters, such as font, color, location, etc.") +;; calendar-basic-setup is called first, and will autoload diary-lib. +(declare-function make-fancy-diary-buffer "diary-lib" nil) + (defun calendar-one-frame-setup (&optional arg) "Start calendar and display it in a dedicated frame together with the diary. This function requires a display capable of multiple frames, else diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index c252341526a..d49667d2810 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1,7 +1,8 @@ ;;; calendar.el --- calendar functions ;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1997, -;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 +;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> ;; Maintainer: Glenn Morris <rgm@gnu.org> @@ -818,7 +819,7 @@ diary buffer, set the variable `diary-list-include-blanks' to t." As the files are processed for diary entries, these functions are used to cull relevant entries. You can use either or both of `list-hebrew-diary-entries', `list-islamic-diary-entries' and -`list-bahai-diary-entries'. The documentation for these functions +`diary-bahai-list-entries'. The documentation for these functions describes the style of such diary entries." :type 'hook :options '(list-hebrew-diary-entries @@ -2444,6 +2445,11 @@ under the cursor: (select-window (posn-window (event-start event))) (call-interactively 'calendar-other-month))) +;; (require 'info) will define these. +(declare-function Info-find-emacs-command-nodes "info" (command)) +(declare-function Info-find-node "info" + (filename nodename &optional no-going-back)) + (defun calendar-goto-info-node () "Go to the info node for the calendar." (interactive) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index f6134940169..cee571f5f1c 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -208,6 +208,7 @@ The optional LABEL is used to label the buffer created." (display-buffer holiday-buffer) (message "Computing holidays...done")))) +;;;###autoload (defalias 'holiday-list 'list-holidays) (defun calendar-check-holidays (date) @@ -487,6 +488,9 @@ is non-nil)." (list (list (calendar-gregorian-from-absolute (+ abs-easter n)) string)))))) +;; Prior call to calendar-julian-from-absolute will autoload cal-julian. +(declare-function calendar-absolute-from-julian "cal-julian" (date)) + (defun holiday-greek-orthodox-easter () "Date of Easter according to the rule of the Council of Nicaea." (let ((m displayed-month) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index d15312abfa3..ffd2b5b6f59 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -53,7 +53,7 @@ the symbols HIGH-SYMBOL, LOW-SYMBOL and MICRO-SYMBOL. The optional TYPE-SYMBOL is bound to the type of the time value. Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH -LOW), and type 3 is the list (HIGH LOW MICRO)." +LOW), and type 2 is the list (HIGH LOW MICRO)." (declare (indent 1) (debug ((&rest (symbolp symbolp symbolp &or [symbolp form] form)) body))) @@ -86,7 +86,7 @@ LOW), and type 3 is the list (HIGH LOW MICRO)." (defun encode-time-value (high low micro type) "Encode HIGH, LOW, and MICRO into a time value of type TYPE. Type 0 is the cons cell (HIGH . LOW), type 1 is the list (HIGH LOW), -and type 3 is the list (HIGH LOW MICRO)." +and type 2 is the list (HIGH LOW MICRO)." (cond ((eq type 0) (cons high low)) ((eq type 1) (list high low)) diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 13ef042f736..e3db7e46407 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -916,6 +916,9 @@ Number of entries for each category is given by `todo-print-priorities'." (defvar date) (defvar entry)) +;; t-c should be used from diary code, which requires calendar. +(declare-function calendar-current-date "calendar" nil) + ;; Read about this function in the setup instructions above! ;;;###autoload (defun todo-cp () diff --git a/lisp/complete.el b/lisp/complete.el index e1d0ef07df4..b3a4928dd53 100644 --- a/lisp/complete.el +++ b/lisp/complete.el @@ -381,9 +381,9 @@ of `minibuffer-completion-table' and the minibuffer contents.") ;; Returns the sequence of non-delimiter characters that follow regexp in string. (defun PC-chunk-after (string regexp) (if (not (string-match regexp string)) - (let ((message (format "String %s didn't match regexp %s" string regexp))) - (message message) - (error message))) + (let ((message "String %s didn't match regexp %s")) + (message message string regexp) + (error message string regexp))) (let ((result (substring string (match-end 0)))) ;; result may contain multiple chunks (if (string-match PC-delim-regex result) @@ -869,7 +869,7 @@ GOTO-END is non-nil, however, it instead replaces up to END." (defun PC-temp-minibuffer-message (message) "A Lisp version of `temp_minibuffer_message' from minibuf.c." (cond (PC-not-minibuffer - (message message) + (message "%s" message) (sit-for 2) (message "")) ((fboundp 'temp-minibuffer-message) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 5e398d46ccf..b9e462ec05f 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -491,6 +491,14 @@ map) "Local keymap for links in `custom-mode'.") +(defvar custom-field-keymap + (let ((map (copy-keymap widget-field-keymap))) + (define-key map "\C-c\C-c" 'Custom-set) + (define-key map "\C-x\C-s" 'Custom-save) + map) + "Keymap used inside editable fields in customization buffers.") + +(widget-put (get 'editable-field 'widget-type) :keymap custom-field-keymap) ;;; Utilities. @@ -4126,6 +4134,9 @@ if only the first line of the docstring is shown.")) (setq user-init-file default-init-file)) user-init-file)))) +;; If recentf-mode is non-nil, this is defined. +(declare-function recentf-expand-file-name "recentf" (name)) + ;;;###autoload (defun custom-save-all () "Save all customizations in `custom-file'." @@ -4435,7 +4446,7 @@ The format is suitable for use with `easy-menu-define'." ;;; Toolbar and menubar support (easy-menu-define - Custom-mode-menu custom-mode-map + Custom-mode-menu (list custom-mode-map custom-field-keymap) "Menu used in customization buffers." (nconc (list "Custom" (customize-menu-create 'customize)) @@ -4473,15 +4484,6 @@ The format is suitable for use with `easy-menu-define'." (widget-apply-action button event) (error "You can't edit this part of the Custom buffer")))) -(defvar custom-field-keymap - (let ((map (copy-keymap widget-field-keymap))) - (define-key map "\C-c\C-c" 'Custom-set) - (define-key map "\C-x\C-s" 'Custom-save) - map) - "Keymap used inside editable fields in customization buffers.") - -(widget-put (get 'editable-field 'widget-type) :keymap custom-field-keymap) - (defun Custom-goto-parent () "Go to the parent group listed at the top of this buffer. If several parents are listed, go to the first of them." @@ -4502,7 +4504,7 @@ If several parents are listed, go to the first of them." (if (eq (widget-get (widget-get widget :parent) :custom-state) 'modified) (message "To install your edits, invoke [State] and choose the Set operation"))) -(defun custom-mode () +(define-derived-mode custom-mode nil "Custom" "Major mode for editing customization buffers. The following commands are available: @@ -4524,9 +4526,6 @@ Erase customizations; set options Entry to this mode calls the value of `custom-mode-hook' if that value is non-nil." - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") (use-local-map custom-mode-map) (easy-menu-add Custom-mode-menu) (set (make-local-variable 'tool-bar-map) custom-tool-bar-map) @@ -4536,6 +4535,7 @@ if that value is non-nil." (setq widget-documentation-face 'custom-documentation) (make-local-variable 'widget-button-face) (setq widget-button-face custom-button) + (setq show-trailing-whitespace nil) ;; We need this because of the "More" button on docstrings. ;; Otherwise clicking on "More" can push point offscreen, which @@ -4553,8 +4553,7 @@ if that value is non-nil." (set (make-local-variable 'widget-push-button-suffix) "") (set (make-local-variable 'widget-link-prefix) "") (set (make-local-variable 'widget-link-suffix) "")) - (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t) - (run-mode-hooks 'custom-mode-hook)) + (add-hook 'widget-edit-functions 'custom-state-buffer-message nil t)) (put 'custom-mode 'mode-class 'special) diff --git a/lisp/desktop.el b/lisp/desktop.el index 6054099bb4d..749956091df 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -651,6 +651,8 @@ is nil, ask the user where to save the desktop." value))) ;; ---------------------------------------------------------------------------- +(declare-function uniquify-item-base "uniquify" (cl-x) t) ; defstruct + (defun desktop-buffer-info (buffer) (set-buffer buffer) (list diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index b9ceb728dbc..32c63aba2fe 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -463,6 +463,56 @@ with a prefix argument." ;;; Shell commands +(declare-function mailcap-parse-mailcaps "mailcap" (&optional path force)) +(declare-function mailcap-parse-mimetypes "mailcap" (&optional path force)) +(declare-function mailcap-extension-to-mime "mailcap" (extn)) +(declare-function mailcap-mime-info "mailcap" + (string &optional request no-decode)) + +(defun dired-read-shell-command-default (files) + "Return a list of default commands for `dired-read-shell-command'." + (require 'mailcap) + (mailcap-parse-mailcaps) + (mailcap-parse-mimetypes) + (let* ((all-mime-type + ;; All unique MIME types from file extensions + (delete-dups (mapcar (lambda (file) + (mailcap-extension-to-mime + (file-name-extension file t))) + files))) + (all-mime-info + ;; All MIME info lists + (delete-dups (mapcar (lambda (mime-type) + (mailcap-mime-info mime-type 'all)) + all-mime-type))) + (common-mime-info + ;; Intersection of mime-infos from different mime-types; + ;; or just the first MIME info for a single MIME type + (if (cdr all-mime-info) + (delq nil (mapcar (lambda (mi1) + (unless (memq nil (mapcar + (lambda (mi2) + (member mi1 mi2)) + (cdr all-mime-info))) + mi1)) + (car all-mime-info))) + (car all-mime-info))) + (commands + ;; Command strings from `viewer' field of the MIME info + (delq nil (mapcar (lambda (mime-info) + (let ((command (cdr (assoc 'viewer mime-info)))) + (if (stringp command) + (replace-regexp-in-string + ;; Replace mailcap's `%s' placeholder + ;; with dired's `?' placeholder + "%s" "?" + (replace-regexp-in-string + ;; Remove the final filename placeholder + "\s*\\('\\)?%s\\1?\s*\\'" "" command nil t) + nil t)))) + common-mime-info)))) + commands)) + (defun dired-read-shell-command (prompt arg files) ;; "Read a dired shell command prompting with PROMPT (using read-string). ;;ARG is the prefix arg and may be used to indicate in the prompt which @@ -472,7 +522,8 @@ with a prefix argument." nil 'shell files (function read-string) (format prompt (dired-mark-prompt arg files)) - nil 'shell-command-history)) + nil 'shell-command-history + (dired-read-shell-command-default files))) ;; The in-background argument is only needed in Emacs 18 where ;; shell-command doesn't understand an appended ampersand `&'. @@ -1151,6 +1202,8 @@ Special value `always' suppresses confirmation." (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t dired-recursive-copies)) +(declare-function make-symbolic-link "fileio.c") + (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) (let ((attrs (file-attributes from)) @@ -1533,10 +1586,16 @@ Optional arg HOW-TO is used to set the value of the into-dir variable "Create a directory called DIRECTORY." (interactive (list (read-file-name "Create directory: " (dired-current-directory)))) - (let ((expanded (directory-file-name (expand-file-name directory)))) - (make-directory expanded) - (dired-add-file expanded) - (dired-move-to-filename))) + (let* ((expanded (directory-file-name (expand-file-name directory))) + (try expanded) new) + ;; Find the topmost nonexistent parent dir (variable `new') + (while (and try (not (file-exists-p try)) (not (equal new try))) + (setq new try + try (directory-file-name (file-name-directory try)))) + (make-directory expanded t) + (when new + (dired-add-file new) + (dired-move-to-filename)))) (defun dired-into-dir-with-symlinks (target) (and (file-directory-p target) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 0be3aa393e1..f8e0b2a6140 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1,15 +1,13 @@ ;;; dired-x.el --- extra Dired functionality -*-byte-compile-dynamic: t;-*- +;; Copyright (C) 1993, 1994, 1997, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. + ;; Author: Sebastian Kremer <sk@thp.uni-koeln.de> ;; Lawrence R. Dodd <dodd@roebling.poly.edu> ;; Maintainer: Romain Francoise <rfrancoise@gnu.org> -;; Version: 2.37+ -;; Date: 1994/08/18 19:27:42 ;; Keywords: dired extensions files -;; Copyright (C) 1993, 1994, 1997, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -652,6 +650,15 @@ Optional fourth argument LOCALP is as in `dired-get-filename'." (and fn (string-match regexp fn)))) msg))) +;; Compiler does not get fset. +(declare-function dired-omit-old-add-entry "dired-x") + +;;; REDEFINE. +;;; Redefine dired-aux.el's version of `dired-add-entry' +;;; Save old defun if not already done: +(or (fboundp 'dired-omit-old-add-entry) + (fset 'dired-omit-old-add-entry (symbol-function 'dired-add-entry))) + ;;; REDEFINE. (defun dired-omit-new-add-entry (filename &optional marker-char relative) ;; This redefines dired-aux.el's dired-add-entry to avoid calling ls for @@ -679,11 +686,6 @@ Optional fourth argument LOCALP is as in `dired-get-filename'." ;; omitting is not turned on at all (dired-omit-old-add-entry filename marker-char relative))) -;;; REDEFINE. -;;; Redefine dired-aux.el's version of `dired-add-entry' -;;; Save old defun if not already done: -(or (fboundp 'dired-omit-old-add-entry) - (fset 'dired-omit-old-add-entry (symbol-function 'dired-add-entry))) ;; Redefine it. (fset 'dired-add-entry 'dired-omit-new-add-entry) @@ -746,7 +748,7 @@ you can relist single subdirs using \\[dired-do-redisplay]." ;; decent subdir headerline: (goto-char (point-min)) (or (looking-at dired-subdir-regexp) - (insert " " + (insert " " (directory-file-name (file-name-directory default-directory)) ":\n")) (dired-mode dirname (or switches dired-listing-switches)) @@ -1211,6 +1213,8 @@ This is an extra function so that you can redefine it." ;;; RELATIVE SYMBOLIC LINKS. +(declare-function make-symbolic-link "fileio.c") + (defvar dired-keep-marker-relsymlink ?S "See variable `dired-keep-marker-move'.") @@ -1437,6 +1441,8 @@ See also variable `dired-vm-read-only-folders'." ;;; MISCELLANEOUS INTERNAL FUNCTIONS. +(declare-function dired-old-find-buffer-nocreate "dired-x") + (or (fboundp 'dired-old-find-buffer-nocreate) (fset 'dired-old-find-buffer-nocreate (symbol-function 'dired-find-buffer-nocreate))) diff --git a/lisp/dired.el b/lisp/dired.el index 16b53acb6da..ab56579e718 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -595,8 +595,12 @@ Don't use that together with FILTER." (if (next-read-file-uses-dialog-p) (read-directory-name (format "Dired %s(directory): " str) nil default-directory nil) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil))))) + (let ((default (and buffer-file-name + (abbreviate-file-name buffer-file-name)))) + (minibuffer-with-setup-hook + (lambda () (setq minibuffer-default default)) + (read-file-name (format "Dired %s(directory): " str) + nil default-directory nil))))))) ;;;###autoload (define-key ctl-x-map "d" 'dired) ;;;###autoload @@ -3264,6 +3268,9 @@ Anything else means ask for each directory." (dired-dnd-handle-local-file uri action) nil))) +(declare-function dired-relist-entry "dired-aux" (file)) +(declare-function make-symbolic-link "fileio.c") + (defun dired-dnd-handle-local-file (uri action) "Copy, move or link a file to the dired directory. URI is the file to handle, ACTION is one of copy, move, link or ask. diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 89f1b009f7f..0e336b12dd5 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -97,16 +97,41 @@ ;; ;; and modify them to your needs. -;;; Code: +;;; Todo: -;; Todo: ;; - better menu. ;; - don't use `find-file'. ;; - Bind slicing to a drag event. -;; - zoom (the whole document and/or just the region around the cursor). +;; - doc-view-fit-doc-to-window and doc-view-fit-window-to-doc. +;; - zoom a the region around the cursor (like xdvi). ;; - get rid of the silly arrow in the fringe. ;; - improve anti-aliasing (pdf-utils gets it better). +;;;; About isearch support + +;; I tried implementing isearch by setting +;; `isearch-search-fun-function' buffer-locally, but that didn't +;; work too good. The function doing the real search was called +;; endlessly somehow. But even if we'd get that working no real +;; isearch feeling comes up due to the missing match highlighting. +;; Currently I display all lines containing a match in a tooltip and +;; each C-s or C-r jumps directly to the next/previous page with a +;; match. With isearch we could only display the current match. So +;; we had to decide if another C-s jumps to the next page with a +;; match (thus only the first match in a page will be displayed in a +;; tooltip) or to the next match, which would do nothing visible +;; (except the tooltip) if the next match is on the same page. + +;; And it's much slower than the current search facility, because +;; isearch really searches for each step forward or backward wheras +;; the current approach searches once and then it knows to which +;; pages to jump. + +;; Anyway, if someone with better isearch knowledge wants to give it a try, +;; feel free to do it. --Tassilo + +;;; Code: + (require 'dired) (require 'image-mode) (require 'jka-compr) @@ -130,11 +155,17 @@ '("-dSAFER" ;; Avoid security problems when rendering files from untrusted ;; sources. "-dNOPAUSE" "-sDEVICE=png16m" "-dTextAlphaBits=4" - "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET" "-r100") + "-dBATCH" "-dGraphicsAlphaBits=4" "-dQUIET") "A list of options to give to ghostscript." :type '(repeat string) :group 'doc-view) +(defcustom doc-view-resolution 100 + "Dots per inch resolution used to render the documents. +Higher values result in larger images." + :type 'number + :group 'doc-view) + (defcustom doc-view-dvipdfm-program (executable-find "dvipdfm") "Program to convert DVI files to PDF. @@ -203,8 +234,12 @@ has finished." (defvar doc-view-current-image nil "Only used internally.") -(defvar doc-view-current-overlay) -(defvar doc-view-pending-cache-flush nil) + +(defvar doc-view-current-overlay nil + "Only used internally.") + +(defvar doc-view-pending-cache-flush nil + "Only used internally.") (defvar doc-view-current-info nil "Only used internally.") @@ -229,6 +264,9 @@ has finished." (define-key map (kbd "M-<") 'doc-view-first-page) (define-key map (kbd "M->") 'doc-view-last-page) (define-key map [remap goto-line] 'doc-view-goto-page) + ;; Zoom in/out. + (define-key map "+" 'doc-view-enlarge) + (define-key map "-" 'doc-view-shrink) ;; Killing/burying the buffer (and the process) (define-key map (kbd "q") 'bury-buffer) (define-key map (kbd "k") 'doc-view-kill-proc-and-buffer) @@ -422,8 +460,40 @@ It's a subdirectory of `doc-view-cache-directory'." (when (not (funcall predicate item)) (setq new-list (cons item new-list)))))) +;;;###autoload +(defun doc-view-mode-p (type) + "Return non-nil if image type TYPE is available for `doc-view'. +Image types are symbols like `dvi', `postscript' or `pdf'." + (and (display-graphic-p) + (image-type-available-p 'png) + (cond + ((eq type 'dvi) + (and (doc-view-mode-p 'pdf) + doc-view-dvipdfm-program + (executable-find doc-view-dvipdfm-program))) + ((or (eq type 'postscript) (eq type 'ps) + (eq type 'pdf)) + (and doc-view-ghostscript-program + (executable-find doc-view-ghostscript-program))) + (t ;; unknown image type + nil)))) + ;;;; Conversion Functions +(defvar doc-view-shrink-factor 1.125) + +(defun doc-view-enlarge (factor) + "Enlarge the document." + (interactive (list doc-view-shrink-factor)) + (set (make-local-variable 'doc-view-resolution) + (* factor doc-view-resolution)) + (doc-view-reconvert-doc)) + +(defun doc-view-shrink (factor) + "Shrink the document." + (interactive (list doc-view-shrink-factor)) + (doc-view-enlarge (/ 1.0 factor))) + (defun doc-view-reconvert-doc () "Reconvert the current document. Should be invoked when the cached images aren't up-to-date." @@ -479,6 +549,7 @@ Should be invoked when the cached images aren't up-to-date." (append (list "pdf/ps->png" doc-view-conversion-buffer doc-view-ghostscript-program) doc-view-ghostscript-options + (list (format "-r%d" (round doc-view-resolution))) (list (concat "-sOutputFile=" png)) (list pdf-ps))) mode-line-process (list (format ":%s" doc-view-current-converter-process))) @@ -738,7 +809,7 @@ the pagenumber and CONTEXTS are all lines of text containing a match." "Call `doc-view-search' for backward search. If prefix NEW-QUERY is given, ask for a new regexp." (interactive "P") - (doc-view-search arg t)) + (doc-view-search new-query t)) (defun doc-view-search (new-query &optional backward) "Jump to the next match or initiate a new search if NEW-QUERY is given. @@ -746,7 +817,7 @@ If the current document hasn't been transformed to plain text till now do that first. If BACKWARD is non-nil, jump to the previous match." (interactive "P") - (if (and (not arg) + (if (and (not new-query) doc-view-current-search-matches) (if backward (doc-view-search-previous-match 1) @@ -820,8 +891,7 @@ If BACKWARD is non-nil, jump to the previous match." (defun doc-view-initiate-display () ;; Switch to image display if possible - (if (and (display-images-p) - (image-type-available-p 'png)) + (if (doc-view-mode-p (intern (file-name-extension buffer-file-name))) (progn (doc-view-buffer-message) (setq doc-view-current-page (or doc-view-current-page 1)) @@ -838,8 +908,9 @@ If BACKWARD is non-nil, jump to the previous match." (message "%s" (substitute-command-keys - (concat "No image (png) support available. Type \\[doc-view-toggle-display] " - "to switch to an editing mode."))))) + (concat "No image (png) support available or some conversion utility for " + (file-name-extension buffer-file-name)" files is missing. " + "Type \\[doc-view-toggle-display] to switch to an editing mode."))))) ;;;###autoload (defun doc-view-mode () diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el index c66cbc7933a..780fdd425a3 100644 --- a/lisp/dos-fns.el +++ b/lisp/dos-fns.el @@ -29,6 +29,9 @@ ;;; Code: +(declare-function int86 "dosfns.c") +(declare-function msdos-long-file-names "msdos.c") + ;; This overrides a trivial definition in files.el. (defun convert-standard-filename (filename) "Convert a standard file's name to something suitable for the current OS. diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el index 28cab4ccbcb..878e5c58189 100644 --- a/lisp/dos-w32.el +++ b/lisp/dos-w32.el @@ -370,6 +370,8 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." (defvar printer-name) +(declare-function default-printer-name "w32fns.c") + (defun direct-print-region-function (start end &optional lpr-prog delete-text buf display diff --git a/lisp/ediff-diff.el b/lisp/ediff-diff.el index 06d7b603440..1b51b440f05 100644 --- a/lisp/ediff-diff.el +++ b/lisp/ediff-diff.el @@ -35,9 +35,9 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) + (load "ediff-util.el" nil t 'nosuffix)) )) ;; end pacifier @@ -343,6 +343,7 @@ one optional arguments, diff-number to refine.") (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*")))) (ediff-with-current-buffer ediff-error-buffer + (setq buffer-undo-list t) (erase-buffer) (insert (ediff-with-current-buffer diff-buff (buffer-string))) (goto-char (point-min)) diff --git a/lisp/ediff-help.el b/lisp/ediff-help.el index 0c37be31372..833260db673 100644 --- a/lisp/ediff-help.el +++ b/lisp/ediff-help.el @@ -33,7 +33,7 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) )) ;; end pacifier diff --git a/lisp/ediff-init.el b/lisp/ediff-init.el index dd69b52b022..b46562b5fde 100644 --- a/lisp/ediff-init.el +++ b/lisp/ediff-init.el @@ -37,10 +37,6 @@ (defvar ediff-multiframe) (defvar ediff-use-toolbar-p) (defvar mswindowsx-bitmap-file-path) - -(and noninteractive - (eval-when-compile - (load "ange-ftp" 'noerror))) ;; end pacifier ;; This is used to avoid compilation warnings. When emacs/xemacs forms can diff --git a/lisp/ediff-merg.el b/lisp/ediff-merg.el index d9d19f17630..95f3efca93b 100644 --- a/lisp/ediff-merg.el +++ b/lisp/ediff-merg.el @@ -37,9 +37,9 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) + (load "ediff-util.el" nil t 'nosuffix)) )) ;; end pacifier diff --git a/lisp/ediff-mult.el b/lisp/ediff-mult.el index 51502615cf7..97c05e3b3cb 100644 --- a/lisp/ediff-mult.el +++ b/lisp/ediff-mult.el @@ -115,9 +115,9 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) + (load "ediff-util.el" nil t 'nosuffix)) )) ;; end pacifier diff --git a/lisp/ediff-ptch.el b/lisp/ediff-ptch.el index 2efa2ac3012..905a07c53df 100644 --- a/lisp/ediff-ptch.el +++ b/lisp/ediff-ptch.el @@ -43,11 +43,11 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) + (load "ediff-mult.el" nil t 'nosuffix)) (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) + (load "ediff.el" nil t 'nosuffix)) )) ;; end pacifier diff --git a/lisp/ediff-util.el b/lisp/ediff-util.el index 2ed8f73a282..a642167474c 100644 --- a/lisp/ediff-util.el +++ b/lisp/ediff-util.el @@ -41,27 +41,23 @@ (defvar ediff-after-quit-hook-internal nil) -(and noninteractive - (eval-when-compile - (load "reporter" 'noerror))) - (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (provide 'ediff-util) ; to break recursive load cycle (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) + (load "ediff-help.el" nil t 'nosuffix)) (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) + (load "ediff-mult.el" nil t 'nosuffix)) (or (featurep 'ediff-wind) - (load "ediff-wind.el" nil nil 'nosuffix)) + (load "ediff-wind.el" nil t 'nosuffix)) (or (featurep 'ediff-diff) - (load "ediff-diff.el" nil nil 'nosuffix)) + (load "ediff-diff.el" nil t 'nosuffix)) (or (featurep 'ediff-merg) - (load "ediff-merg.el" nil nil 'nosuffix)) + (load "ediff-merg.el" nil t 'nosuffix)) (or (featurep 'ediff) - (load "ediff.el" nil nil 'nosuffix)) + (load "ediff.el" nil t 'nosuffix)) (or (featurep 'ediff-tbar) (featurep 'emacs) (load "ediff-tbar.el" 'noerror nil 'nosuffix)) @@ -400,6 +396,9 @@ to invocation.") (setq ediff-error-buffer (get-buffer-create (ediff-unique-buffer-name "*ediff-errors" "*"))) + (with-current-buffer ediff-error-buffer + (setq buffer-undo-list t)) + (ediff-with-current-buffer buffer-A (ediff-strip-mode-line-format)) (ediff-with-current-buffer buffer-B (ediff-strip-mode-line-format)) (if ediff-3way-job @@ -2818,6 +2817,9 @@ up an appropriate window config." "To resume, type M-x eregistry and select the desired Ediff session")) +;; ediff-barf-if-not-control-buffer ensures only called from ediff. +(declare-function ediff-version "ediff" ()) + (defun ediff-status-info () "Show the names of the buffers or files being operated on by Ediff. Hit \\[ediff-recenter] to reset the windows afterward." diff --git a/lisp/ediff-vers.el b/lisp/ediff-vers.el index 293acc5a854..0fd06176b46 100644 --- a/lisp/ediff-vers.el +++ b/lisp/ediff-vers.el @@ -41,7 +41,7 @@ (load "rcs" 'noerror) ;; (load "vc" 'noerror) ; this sometimes causes compiler error (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) ))) ;; end pacifier diff --git a/lisp/ediff-wind.el b/lisp/ediff-wind.el index 8b72a673d17..e13d89ac6eb 100644 --- a/lisp/ediff-wind.el +++ b/lisp/ediff-wind.el @@ -43,11 +43,11 @@ (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-util) - (load "ediff-util.el" nil nil 'nosuffix)) + (load "ediff-util.el" nil t 'nosuffix)) (or (featurep 'ediff-help) - (load "ediff-help.el" nil nil 'nosuffix)) + (load "ediff-help.el" nil t 'nosuffix)) (or (featurep 'ediff-tbar) (featurep 'emacs) (load "ediff-tbar.el" 'noerror nil 'nosuffix)) @@ -77,7 +77,7 @@ Ediff provides a choice of three functions: `ediff-setup-windows-plain', for doing everything in one frame, `ediff-setup-windows-multiframe', which sets the control panel in a separate frame, and `ediff-setup-windows-automatic' (the default), which chooses an appropriate -behaviour based on the current window system. If the multiframe function +behavior based on the current window system. If the multiframe function detects that one of the buffers A/B is seen in some other frame, it will try to keep that buffer in that frame. @@ -147,6 +147,10 @@ In this case, Ediff will use those frames to display these buffers." :type 'function :group 'ediff-window) +;; Definitions hidden from the compiler by compat wrappers. +(declare-function ediff-display-pixel-width "ediff-init") +(declare-function ediff-display-pixel-height "ediff-init") + (defconst ediff-control-frame-parameters (list '(name . "Ediff") diff --git a/lisp/ediff.el b/lisp/ediff.el index a2aafc90292..a53b93aee5b 100644 --- a/lisp/ediff.el +++ b/lisp/ediff.el @@ -113,22 +113,20 @@ (defvar ediff-last-dir-patch) (defvar ediff-patch-default-directory) -(and noninteractive - (eval-when-compile - (load-library "dired") - (load-library "info") - (load "pcl-cvs" 'noerror))) + (eval-when-compile + (and noninteractive + (load "dired" nil t)) (let ((load-path (cons (expand-file-name ".") load-path))) (provide 'ediff) ; to break recursive load cycle (or (featurep 'ediff-init) - (load "ediff-init.el" nil nil 'nosuffix)) + (load "ediff-init.el" nil t 'nosuffix)) (or (featurep 'ediff-mult) - (load "ediff-mult.el" nil nil 'nosuffix)) + (load "ediff-mult.el" nil t 'nosuffix)) (or (featurep 'ediff-ptch) - (load "ediff-ptch.el" nil nil 'nosuffix)) + (load "ediff-ptch.el" nil t 'nosuffix)) (or (featurep 'ediff-vers) - (load "ediff-vers.el" nil nil 'nosuffix)) + (load "ediff-vers.el" nil t 'nosuffix)) )) ;; end pacifier @@ -363,6 +361,7 @@ (list (cons 'ediff-job-name job-name)) merge-buffer-file))) +(declare-function diff-latest-backup-file "diff" (fn)) ;;;###autoload (defalias 'ediff 'ediff-files) @@ -1424,9 +1423,11 @@ Uses `vc.el' or `rcs.el' depending on `ediff-version-control-package'." When called interactively, displays the version." (interactive) (if (interactive-p) - (message (ediff-version)) + (message "%s" (ediff-version)) (format "Ediff %s of %s" ediff-version ediff-date))) +;; info is run first, and will autoload info.el. +(declare-function Info-goto-node "info" (nodename &optional fork)) ;;;###autoload (defun ediff-documentation (&optional node) diff --git a/lisp/emacs-lisp/authors.el b/lisp/emacs-lisp/authors.el index 50d2f41f7ae..486a02d2c6b 100644 --- a/lisp/emacs-lisp/authors.el +++ b/lisp/emacs-lisp/authors.el @@ -418,24 +418,6 @@ author and what he did in hash table TABLE. See the description of (nconc entry (list (cons action 1)))))))) -(defun authors-process-lines (program &rest args) - "Execute PROGRAM with ARGS, returning its output as a list of lines. -Signal an error if the program returns with a non-zero exit status." - (with-temp-buffer - (let ((status (apply 'call-process program nil (current-buffer) nil args))) - (unless (eq status 0) - (error "%s exited with status %s" program status)) - (goto-char (point-min)) - (let (lines) - (while (not (eobp)) - (setq lines (cons (buffer-substring-no-properties - (line-beginning-position) - (line-end-position)) - lines)) - (forward-line 1)) - (nreverse lines))))) - - (defun authors-canonical-author-name (author) "Return a canonicalized form of AUTHOR, an author name. If AUTHOR has an alias, use that. Remove email addresses. Capitalize @@ -605,7 +587,7 @@ Result is a buffer *Authors* containing authorship information, and a buffer *Authors Errors* containing references to unknown files." (interactive "DEmacs source directory: ") (setq root (expand-file-name root)) - (let ((logs (authors-process-lines "find" root "-name" "ChangeLog*")) + (let ((logs (process-lines "find" root "-name" "ChangeLog*")) (table (make-hash-table :test 'equal)) (buffer-name "*Authors*") authors-checked-files-alist @@ -617,7 +599,7 @@ buffer *Authors Errors* containing references to unknown files." (when (string-match "ChangeLog\\(.[0-9]+\\)?$" log) (message "Scanning %s..." log) (authors-scan-change-log log table))) - (let ((els (authors-process-lines "find" root "-name" "*.el"))) + (let ((els (process-lines "find" root "-name" "*.el"))) (dolist (file els) (message "Scanning %s..." file) (authors-scan-el file table))) diff --git a/lisp/emacs-lisp/backquote.el b/lisp/emacs-lisp/backquote.el index a2a929d9601..4940e2fd8c6 100644 --- a/lisp/emacs-lisp/backquote.el +++ b/lisp/emacs-lisp/backquote.el @@ -92,7 +92,7 @@ For example (backquote-list* 'a 'b 'c) => (a b . c)" "Symbol used to represent a splice inside a backquote.") ;;;###autoload -(defmacro backquote (arg) +(defmacro backquote (structure) "Argument STRUCTURE describes a template to build. The whole structure acts as if it were quoted except for certain @@ -106,7 +106,7 @@ b => (ba bb bc) ; assume b has this value `(a ,@b c) => (a ba bb bc c) ; splice in the value of b Vectors work just like lists. Nested backquotes are permitted." - (cdr (backquote-process arg))) + (cdr (backquote-process structure))) ;; GNU Emacs has no reader macros diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index bc864aab490..eb8c80af145 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -185,6 +185,7 @@ ;;; Code: (require 'bytecomp) +(eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) (if (aref byte-code-vector 0) @@ -276,6 +277,8 @@ ;; Isn't it an error for `string' not to be unibyte?? --stef (if (fboundp 'string-as-unibyte) (setq string (string-as-unibyte string))) + ;; `byte-compile-splice-in-already-compiled-code' + ;; takes care of inlining the body. (cons `(lambda ,(aref fn 0) (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) @@ -625,13 +628,24 @@ ;; ;; It is now safe to optimize code such that it introduces new bindings. -;; I'd like this to be a defsubst, but let's not be self-referential... -(defmacro byte-compile-trueconstp (form) - ;; Returns non-nil if FORM is a non-nil constant. - `(cond ((consp ,form) (eq (car ,form) 'quote)) - ((not (symbolp ,form))) - ((eq ,form t)) - ((keywordp ,form)))) +(defsubst byte-compile-trueconstp (form) + "Return non-nil if FORM always evaluates to a non-nil value." + (cond ((consp form) + (case (car form) + (quote (cadr form)) + (progn (byte-compile-trueconstp (car (last (cdr form))))))) + ((not (symbolp form))) + ((eq form t)) + ((keywordp form)))) + +(defsubst byte-compile-nilconstp (form) + "Return non-nil if FORM always evaluates to a nil value." + (cond ((consp form) + (case (car form) + (quote (null (cadr form))) + (progn (byte-compile-nilconstp (car (last (cdr form))))))) + ((not (symbolp form)) nil) + ((null form)))) ;; If the function is being called with constant numeric args, ;; evaluate as much as possible at compile-time. This optimizer @@ -990,17 +1004,17 @@ (setq rest form) (while (setq rest (cdr rest)) (cond ((byte-compile-trueconstp (car-safe (car rest))) - (cond ((eq rest (cdr form)) - (setq form - (if (cdr (car rest)) - (if (cdr (cdr (car rest))) - (cons 'progn (cdr (car rest))) - (nth 1 (car rest))) - (car (car rest))))) + ;; This branch will always be taken: kill the subsequent ones. + (cond ((eq rest (cdr form)) ;First branch of `cond'. + (setq form `(progn ,@(car rest)))) ((cdr rest) (setq form (copy-sequence form)) (setcdr (memq (car rest) form) nil))) - (setq rest nil))))) + (setq rest nil)) + ((and (consp (car rest)) + (byte-compile-nilconstp (caar rest))) + ;; This branch will never be taken: kill its body. + (setcdr (car rest) nil))))) ;; ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) (if (eq 'cond (car-safe form)) @@ -1031,11 +1045,9 @@ (byte-optimize-if `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) - (nth 2 form)) - ((null clause) - (if (nthcdr 4 form) - (cons 'progn (nthcdr 3 form)) - (nth 3 form))) + `(progn ,clause ,(nth 2 form))) + ((byte-compile-nilconstp clause) + `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) (list 'if clause (nth 2 form)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 27ee27eda92..82866a07ff7 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1053,6 +1053,9 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (defun byte-compile-warning-series (&rest ignore) nil) +;; (compile-mode) will cause this to be loaded. +(declare-function compilation-forget-errors "compile" ()) + ;; Log the start of a file in *Compile-Log*, and mark it as done. ;; Return the position of the start of the page in the log buffer. ;; But do nothing in batch mode. @@ -1258,7 +1261,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (byte-compile-fdefinition (car form) t))) (sig (if (and def (not (eq def t))) (byte-compile-arglist-signature - (if (eq 'lambda (car-safe def)) + (if (memq (car-safe def) '(declared lambda)) (nth 1 def) (if (byte-code-function-p def) (aref def 0) @@ -2274,18 +2277,17 @@ list that represents a doc string reference. (byte-compile-nogroup-warn form)) (when (byte-compile-warning-enabled-p 'free-vars) (push (nth 1 (nth 1 form)) byte-compile-bound-variables)) + ;; Don't compile the expression because it may be displayed to the user. + ;; (when (eq (car-safe (nth 2 form)) 'quote) + ;; ;; (nth 2 form) is meant to evaluate to an expression, so if we have the + ;; ;; final value already, we can byte-compile it. + ;; (setcar (cdr (nth 2 form)) + ;; (byte-compile-top-level (cadr (nth 2 form)) nil 'file))) (let ((tail (nthcdr 4 form))) (while tail - ;; If there are any (function (lambda ...)) expressions, compile - ;; those functions. - (if (and (consp (car tail)) - (eq (car (car tail)) 'function) - (consp (nth 1 (car tail)))) - (setcar tail (byte-compile-lambda (nth 1 (car tail)))) - ;; Likewise for a bare lambda. - (if (and (consp (car tail)) - (eq (car (car tail)) 'lambda)) - (setcar tail (byte-compile-lambda (car tail))))) + (unless (keywordp (car tail)) ;No point optimizing keywords. + ;; Compile the keyword arguments. + (setcar tail (byte-compile-top-level (car tail) nil 'file))) (setq tail (cdr tail)))) form) @@ -2817,6 +2819,20 @@ If FORM is a lambda or a macro, byte-compile it as a function." (cdr body)) (body (list body)))) + +(put 'declare-function 'byte-hunk-handler 'byte-compile-declare-function) +(defun byte-compile-declare-function (form) + (push (cons (nth 1 form) + (if (and (> (length form) 3) + (listp (nth 3 form))) + (list 'declared (nth 3 form)) + t)) ; arglist not specified + byte-compile-function-environment) + ;; We are stating that it _will_ be defined at runtime. + (setq byte-compile-noruntime-functions + (delq (nth 1 form) byte-compile-noruntime-functions)) + nil) + ;; This is the recursive entry point for compiling each subform of an ;; expression. @@ -3496,12 +3512,12 @@ That command is designed for interactive use only" fn)) ;; Return the list of items in CONDITION-PARAM that match PRED-LIST. ;; Only return items that are not in ONLY-IF-NOT-PRESENT. -(defun byte-compile-find-bound-condition (condition-param - pred-list +(defun byte-compile-find-bound-condition (condition-param + pred-list &optional only-if-not-present) (let ((result nil) (nth-one nil) - (cond-list + (cond-list (if (memq (car-safe condition-param) pred-list) ;; The condition appears by itself. (list condition-param) @@ -3509,7 +3525,7 @@ That command is designed for interactive use only" fn)) ;; `and' arguments. (when (eq 'and (car-safe condition-param)) (cdr condition-param))))) - + (dolist (crt cond-list) (when (and (memq (car-safe crt) pred-list) (eq 'quote (car-safe (setq nth-one (nth 1 crt)))) @@ -3531,10 +3547,10 @@ being undefined will be suppressed. If CONDITION's value is (not (featurep 'emacs)) or (featurep 'xemacs), that suppresses all warnings during execution of BODY." (declare (indent 1) (debug t)) - `(let* ((fbound-list (byte-compile-find-bound-condition - ,condition (list 'fboundp) + `(let* ((fbound-list (byte-compile-find-bound-condition + ,condition (list 'fboundp) byte-compile-unresolved-functions)) - (bound-list (byte-compile-find-bound-condition + (bound-list (byte-compile-find-bound-condition ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables @@ -4264,7 +4280,7 @@ Must be used only with `-batch', and kills Emacs on completion. For example, invoke `emacs -batch -f batch-byte-recompile-directory .'. Optional argument ARG is passed as second argument ARG to -`batch-recompile-directory'; see there for its possible values +`byte-recompile-directory'; see there for its possible values and corresponding effects." ;; command-line-args-left is what is left of the command line (startup.el) (defvar command-line-args-left) ;Avoid 'free variable' warning diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el new file mode 100644 index 00000000000..9fc8a9e61e7 --- /dev/null +++ b/lisp/emacs-lisp/check-declare.el @@ -0,0 +1,311 @@ +;;; check-declare.el --- Check declare-function statements + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Glenn Morris <rgm@gnu.org> +;; Keywords: lisp, tools, maint + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; The byte-compiler often warns about undefined functions that you +;; know will actually be defined when it matters. The `declare-function' +;; statement allows you to suppress these warnings. This package +;; checks that all such statements in a file or directory are accurate. +;; The entry points are `check-declare-file' and `check-declare-directory'. + +;; For more information, see Info node `elisp(Declaring Functions)'. + +;;; TODO: + +;;; Code: + +(defconst check-declare-warning-buffer "*Check Declarations Warnings*" + "Name of buffer used to display any `check-declare' warnings.") + +(defun check-declare-locate (file basefile) + "Return the full path of FILE. +Expands files with a \".c\" extension relative to the Emacs +\"src/\" directory. Otherwise, `locate-library' searches for FILE. +If that fails, expands FILE relative to BASEFILE's directory part. +The returned file might not exist. If FILE has an \"ext:\" prefix, so does +the result." + (let ((ext (string-match "^ext:" file)) + tfile) + (if ext + (setq file (substring file 4))) + (setq file + (if (string-equal "c" (file-name-extension file)) + (expand-file-name file (expand-file-name "src" source-directory)) + (if (setq tfile (locate-library (file-name-nondirectory file))) + (progn + (setq tfile + (replace-regexp-in-string "\\.elc\\'" ".el" tfile)) + (if (and (not (file-exists-p tfile)) + (file-exists-p (concat tfile ".gz"))) + (concat tfile ".gz") + tfile)) + (setq tfile (expand-file-name file + (file-name-directory basefile))) + (if (or (file-exists-p tfile) + (string-match "\\.el\\'" tfile)) + tfile + (concat tfile ".el"))))) + (if ext (concat "ext:" file) + file))) + +(defun check-declare-scan (file) + "Scan FILE for `declare-function' calls. +Return a list with elements of the form (FNFILE FN ARGLIST FILEONLY), +where only the first two elements need be present. This claims that FNFILE +defines FN, with ARGLIST. FILEONLY non-nil means only check that FNFILE +exists, not that it defines FN. This is for function definitions that we +don't know how to recognize (e.g. some macros)." + (let ((m (format "Scanning %s..." file)) + alist fnfile fn arglist fileonly) + (message "%s" m) + (with-temp-buffer + (insert-file-contents file) + (while (re-search-forward + "^[ \t]*(declare-function[ \t]+\\(\\S-+\\)[ \t]+\ +\"\\(\\S-+\\)\"" nil t) + (setq fn (match-string 1) + fnfile (match-string 2) + fnfile (check-declare-locate fnfile (expand-file-name file)) + arglist (progn + (skip-chars-forward " \t\n") + ;; Use `t' to distinguish no arglist + ;; specified from an empty one. + (if (looking-at "\\((\\|nil\\|t\\)") + (read (current-buffer)) + t)) + fileonly (progn + (skip-chars-forward " \t\n") + (if (looking-at "\\(t\\|'\\sw+\\)") + (match-string 1))) + alist (cons (list fnfile fn arglist fileonly) alist)))) + (message "%sdone" m) + alist)) + +(defun check-declare-errmsg (errlist &optional full) + "Return a string with the number of errors in ERRLIST, if any. +Normally just counts the number of elements in ERRLIST. +With optional argument FULL, sums the number of elements in each element." + (if errlist + (let ((l (length errlist))) + (when full + (setq l 0) + (dolist (e errlist) + (setq l (1+ l)))) + (format "%d problem%s found" l (if (= l 1) "" "s"))) + "OK")) + +(autoload 'byte-compile-arglist-signature "bytecomp") + +(defun check-declare-verify (fnfile fnlist) + "Check that FNFILE contains function definitions matching FNLIST. +Each element of FNLIST has the form (FILE FN ARGLIST FILEONLY), where +only the first two elements need be present. This means FILE claimed FN +was defined in FNFILE with the specified ARGLIST. FILEONLY non-nil means +to only check that FNFILE exists, not that it actually defines FN. + +Returns nil if all claims are found to be true, otherwise a list +of errors with elements of the form \(FILE FN TYPE), where TYPE +is a string giving details of the error." + (let ((m (format "Checking %s..." fnfile)) + (cflag (string-equal "c" (file-name-extension fnfile))) + (ext (string-match "^ext:" fnfile)) + re fn sig siglist arglist type errlist minargs maxargs) + (message "%s" m) + (if ext + (setq fnfile (substring fnfile 4))) + (if (file-exists-p fnfile) + (with-temp-buffer + (insert-file-contents fnfile) + ;; defsubst's don't _have_ to be known at compile time. + (setq re (format (if cflag + "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\"" + "^[ \t]*(\\(fset[ \t]+'\\|def\\(?:un\\|subst\\|\ +ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\ +\\|\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\)\\)\ +\[ \t]*%s\\([ \t;]+\\|$\\)") + (regexp-opt (mapcar 'cadr fnlist) t))) + (while (re-search-forward re nil t) + (skip-chars-forward " \t\n") + (setq fn (match-string 2) + type (match-string 1) + ;; (min . max) for a fixed number of arguments, or + ;; arglists with optional elements. + ;; (min) for arglists with &rest. + ;; sig = 'err means we could not find an arglist. + sig (cond (cflag + (or + (when (re-search-forward "," nil t 3) + (skip-chars-forward " \t\n") + ;; Assuming minargs and maxargs on same line. + (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\ +\\([0-9]+\\|MANY\\|UNEVALLED\\)") + (setq minargs (string-to-number + (match-string 1)) + maxargs (match-string 2)) + (cons minargs (unless (string-match "[^0-9]" + maxargs) + (string-to-number + maxargs))))) + 'err)) + ((string-match + "\\`define-\\(derived\\|generic\\)-mode\\'" + type) + '(0 . 0)) + ((string-match + "\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'" + type) + '(0 . 1)) + ;; Prompt to update. + ((string-match + "\\`define-obsolete-function-alias\\>" + type) + 'obsolete) + ;; Can't easily check arguments in these cases. + ((string-match "\\`\\(defalias\\|fset\\)\\>" type) + t) + ((looking-at "\\((\\|nil\\)") + (byte-compile-arglist-signature + (read (current-buffer)))) + (t + 'err)) + ;; alist of functions and arglist signatures. + siglist (cons (cons fn sig) siglist))))) + (dolist (e fnlist) + (setq arglist (nth 2 e) + type + (if (not re) + "file not found" + (if (not (setq sig (assoc (cadr e) siglist))) + (unless (nth 3 e) ; fileonly + "function not found") + (setq sig (cdr sig)) + (cond ((eq sig 'obsolete) ; check even when no arglist specified + "obsolete alias") + ;; arglist t means no arglist specified, as + ;; opposed to an empty arglist. + ((eq arglist t) nil) + ((eq sig t) nil) ; eg defalias - can't check arguments + ((eq sig 'err) + "arglist not found") ; internal error + ((not (equal (byte-compile-arglist-signature + arglist) + sig)) + "arglist mismatch"))))) + (when type + (setq errlist (cons (list (car e) (cadr e) type) errlist)))) + (message "%s%s" m + (if (or re (not ext)) + (check-declare-errmsg errlist) + (progn + (setq errlist nil) + "skipping external file"))) + errlist)) + +(defun check-declare-sort (alist) + "Sort a list with elements FILE (FNFILE ...). +Returned list has elements FNFILE (FILE ...)." + (let (file fnfile rest sort a) + (dolist (e alist) + (setq file (car e)) + (dolist (f (cdr e)) + (setq fnfile (car f) + rest (cdr f)) + (if (setq a (assoc fnfile sort)) + (setcdr a (append (cdr a) (list (cons file rest)))) + (setq sort (cons (list fnfile (cons file rest)) sort))))) + sort)) + +(defun check-declare-warn (file fn fnfile type) + "Warn that FILE made a false claim about FN in FNFILE. +TYPE is a string giving the nature of the error. Warning is displayed in +`check-declare-warning-buffer'." + (display-warning 'check-declare + (format "%s said `%s' was defined in %s: %s" + (file-name-nondirectory file) fn + (file-name-nondirectory fnfile) + type) + nil check-declare-warning-buffer)) + +(defun check-declare-files (&rest files) + "Check veracity of all `declare-function' statements in FILES. +Return a list of any errors found." + (let (alist err errlist) + (dolist (file files) + (setq alist (cons (cons file (check-declare-scan file)) alist))) + ;; Sort so that things are ordered by the files supposed to + ;; contain the defuns. + (dolist (e (check-declare-sort alist)) + (if (setq err (check-declare-verify (car e) (cdr e))) + (setq errlist (cons (cons (car e) err) errlist)))) + (if (get-buffer check-declare-warning-buffer) + (kill-buffer check-declare-warning-buffer)) + ;; Sort back again so that errors are ordered by the files + ;; containing the declare-function statements. + (dolist (e (check-declare-sort errlist)) + (dolist (f (cdr e)) + (check-declare-warn (car e) (cadr f) (car f) (nth 2 f)))) + errlist)) + +;;;###autoload +(defun check-declare-file (file) + "Check veracity of all `declare-function' statements in FILE. +See `check-declare-directory' for more information." + (interactive "fFile to check: ") + (or (file-exists-p file) + (error "File `%s' not found" file)) + (let ((m (format "Checking %s..." file)) + errlist) + (message "%s" m) + (setq errlist (check-declare-files file)) + (message "%s%s" m (check-declare-errmsg errlist)) + errlist)) + +;;;###autoload +(defun check-declare-directory (root) + "Check veracity of all `declare-function' statements under directory ROOT. +Returns non-nil if any false statements are found. For this to +work correctly, the statements must adhere to the format +described in the documentation of `declare-function'." + (interactive "DDirectory to check: ") + (or (file-directory-p (setq root (expand-file-name root))) + (error "Directory `%s' not found" root)) + (let ((m "Checking `declare-function' statements...") + (m2 "Finding files with declarations...") + errlist files) + (message "%s" m) + (message "%s" m2) + (setq files (process-lines "find" root "-name" "*.el" + "-exec" "grep" "-l" + "^[ ]*(declare-function" "{}" ";")) + (message "%s%d found" m2 (length files)) + (when files + (setq errlist (apply 'check-declare-files files)) + (message "%s%s" m (check-declare-errmsg errlist t)) + errlist))) + +(provide 'check-declare) + +;; arch-tag: a4d6cdc4-deb7-4502-b327-0e4ef3d82d96 +;;; check-declare.el ends here. diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el index b802d8acd43..d6c23de0be8 100644 --- a/lisp/emacs-lisp/easymenu.el +++ b/lisp/emacs-lisp/easymenu.el @@ -116,10 +116,15 @@ whenever this expression's value is non-nil. INCLUDE is an expression; this item is only visible if this expression has a non-nil value. `:included' is an alias for `:visible'. + :label FORM + +FORM is an expression that will be dynamically evaluated and whose +value will be used for the menu entry's text label (the default is NAME). + :suffix FORM FORM is an expression that will be dynamically evaluated and whose -value will be concatenated to the menu entry's NAME. +value will be concatenated to the menu entry's label. :style STYLE diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index b3c7c339030..24e26827f7c 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -149,10 +149,14 @@ See the functions `find-function' and `find-variable'." ;; the same name. (if (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library) (setq library (replace-match "" t t library))) - (or (locate-file library - (or find-function-source-path load-path) - (append (find-library-suffixes) load-file-rep-suffixes)) - (error "Can't find library %s" library))) + (or + (locate-file library + (or find-function-source-path load-path) + (find-library-suffixes)) + (locate-file library + (or find-function-source-path load-path) + load-file-rep-suffixes) + (error "Can't find library %s" library))) (defvar find-function-C-source-directory (let ((dir (expand-file-name "src" source-directory))) diff --git a/lisp/emacs-lisp/gulp.el b/lisp/emacs-lisp/gulp.el index 9e0795c8822..5ff2b8f564c 100644 --- a/lisp/emacs-lisp/gulp.el +++ b/lisp/emacs-lisp/gulp.el @@ -78,6 +78,9 @@ Thanks.") :type 'string :group 'gulp) +(declare-function mail-subject "sendmail" ()) +(declare-function mail-send "sendmail" ()) + (defun gulp-send-requests (dir &optional time) "Send requests for updates to the authors of Lisp packages in directory DIR. For each maintainer, the message consists of `gulp-request-header', diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 788be284cda..65bbade816e 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -175,9 +175,10 @@ normal recipe (see `beginning-of-defun'). Major modes can define this if defining `defun-prompt-regexp' is not sufficient to handle the mode's needs. -The function (of no args) should go to the line on which the current -defun starts, and return non-nil, or should return nil if it can't -find the beginning.") +The function takes the same argument as `beginning-of-defun' and should +behave similarly, returning non-nil if it found the beginning of a defun. +Ideally it should move to a point right before an open-paren which encloses +the body of the defun.") (defun beginning-of-defun (&optional arg) "Move backward to the beginning of a defun. @@ -218,12 +219,22 @@ is called as a function to find the defun's beginning." (unless arg (setq arg 1)) (cond (beginning-of-defun-function - (if (> arg 0) - (dotimes (i arg) - (funcall beginning-of-defun-function)) - ;; Better not call end-of-defun-function directly, in case - ;; it's not defined. - (end-of-defun (- arg)))) + (condition-case nil + (funcall beginning-of-defun-function arg) + ;; We used to define beginning-of-defun-function as taking no argument + ;; but that makes it impossible to implement correct forward motion: + ;; we used to use end-of-defun for that, but it's not supposed to do + ;; the same thing (it moves to the end of a defun not to the beginning + ;; of the next). + ;; In case the beginning-of-defun-function uses the old calling + ;; convention, fallback on the old implementation. + (wrong-number-of-arguments + (if (> arg 0) + (dotimes (i arg) + (funcall beginning-of-defun-function)) + ;; Better not call end-of-defun-function directly, in case + ;; it's not defined. + (end-of-defun (- arg)))))) ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) (and (< arg 0) (not (eobp)) (forward-char 1)) @@ -286,11 +297,11 @@ is called as a function to find the defun's beginning." (goto-char (if arg-+ve floor ceiling)) nil)))))))) -(defvar end-of-defun-function nil - "If non-nil, function for function `end-of-defun' to call. -This is used to find the end of the defun instead of using the normal -recipe (see `end-of-defun'). Major modes can define this if the -normal method is not appropriate.") +(defvar end-of-defun-function #'forward-sexp + "Function for `end-of-defun' to call. +This is used to find the end of the defun. +It is called with no argument, right after calling `beginning-of-defun-raw'. +So the function can assume that point is at the beginning of the defun body.") (defun buffer-end (arg) "Return the \"far end\" position of the buffer, in direction ARG. @@ -315,45 +326,38 @@ is called as a function to find the defun's end." (and transient-mark-mode mark-active) (push-mark)) (if (or (null arg) (= arg 0)) (setq arg 1)) - (if end-of-defun-function - (if (> arg 0) - (dotimes (i arg) - (funcall end-of-defun-function)) - ;; Better not call beginning-of-defun-function - ;; directly, in case it's not defined. - (beginning-of-defun (- arg))) - (let ((first t)) - (while (and (> arg 0) (< (point) (point-max))) - (let ((pos (point))) - (while (progn - (if (and first - (progn - (end-of-line 1) - (beginning-of-defun-raw 1))) - nil - (or (bobp) (forward-char -1)) - (beginning-of-defun-raw -1)) - (setq first nil) - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1)) - (<= (point) pos)))) - (setq arg (1- arg))) - (while (< arg 0) - (let ((pos (point))) - (beginning-of-defun-raw 1) - (forward-sexp 1) - (forward-line 1) - (if (>= (point) pos) - (if (beginning-of-defun-raw 2) - (progn - (forward-list 1) - (skip-chars-forward " \t") - (if (looking-at "\\s<\\|\n") - (forward-line 1))) - (goto-char (point-min))))) - (setq arg (1+ arg)))))) + (while (> arg 0) + (let ((pos (point))) + (end-of-line 1) + (beginning-of-defun-raw 1) + (while (unless (eobp) + (funcall end-of-defun-function) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)) + ;; If we started after the end of the previous function, then + ;; try again with the next one. + (when (<= (point) pos) + (or (bobp) (forward-char -1)) + (beginning-of-defun-raw -1) + 'try-again)))) + (setq arg (1- arg))) + (while (< arg 0) + (let ((pos (point))) + (while (unless (bobp) + (beginning-of-line 1) + (beginning-of-defun-raw 1) + (let ((beg (point))) + (funcall end-of-defun-function) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1)) + ;; If we started from within the function just found, then + ;; try again with the previous one. + (when (>= (point) pos) + (goto-char beg) + 'try-again))))) + (setq arg (1+ arg)))) (defun mark-defun (&optional allow-extend) "Put mark at end of this defun, point at beginning. @@ -562,12 +566,47 @@ character." ;; "Unbalanced parentheses", but those may not be so ;; accurate/helpful, e.g. quotes may actually be ;; mismatched. - (error "Unmatched bracket or quote")) - (error (cond ((eq 'scan-error (car data)) - (goto-char (nth 2 data)) - (error "Unmatched bracket or quote")) - (t (signal (car data) (cdr data))))))) + (error "Unmatched bracket or quote")))) +(defun field-complete (table &optional predicate) + (let* ((pattern (field-string-no-properties)) + (completion (try-completion pattern table predicate))) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= pattern completion)) + (delete-region (field-beginning) (field-end)) + (insert completion) + ;; Don't leave around a completions buffer that's out of date. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer))))) + (t + (let ((minibuf-is-in-use + (eq (minibuffer-window) (selected-window)))) + (unless minibuf-is-in-use + (message "Making completion list...")) + (let ((list (all-completions pattern table predicate))) + (setq list (sort list 'string<)) + (or (eq predicate 'fboundp) + (let (new) + (while list + (setq new (cons (if (fboundp (intern (car list))) + (list (car list) " <f>") + (car list)) + new)) + (setq list (cdr list))) + (setq list (nreverse new)))) + (if (> (length list) 1) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list pattern)) + ;; Don't leave around a completions buffer that's + ;; out of date. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer)))))) + (unless minibuf-is-in-use + (message "Making completion list...%s" "done"))))))) + (defun lisp-complete-symbol (&optional predicate) "Perform completion on Lisp symbol preceding point. Compare that symbol against the known Lisp symbols. diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el index 93cf434292a..d9ce48e23a6 100644 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@ -51,8 +51,8 @@ (defun ring-p (x) "Return t if X is a ring; nil otherwise." (and (consp x) (integerp (car x)) - (consp (cdr x)) (integerp (car (cdr x))) - (vectorp (cdr (cdr x))))) + (consp (cdr x)) (integerp (cadr x)) + (vectorp (cddr x)))) ;;;###autoload (defun make-ring (size) @@ -60,11 +60,11 @@ (cons 0 (cons 0 (make-vector size nil)))) (defun ring-insert-at-beginning (ring item) - "Add to RING the item ITEM. Add it at the front, as the oldest item." - (let* ((vec (cdr (cdr ring))) + "Add to RING the item ITEM, at the front, as the oldest item." + (let* ((vec (cddr ring)) (veclen (length vec)) (hd (car ring)) - (ln (car (cdr ring)))) + (ln (cadr ring))) (setq ln (min veclen (1+ ln)) hd (ring-minus1 hd veclen)) (aset vec hd item) @@ -73,16 +73,16 @@ (defun ring-plus1 (index veclen) "Return INDEX+1, with wraparound." - (let ((new-index (+ index 1))) + (let ((new-index (1+ index))) (if (= new-index veclen) 0 new-index))) (defun ring-minus1 (index veclen) "Return INDEX-1, with wraparound." - (- (if (= 0 index) veclen index) 1)) + (- (if (zerop index) veclen index) 1)) (defun ring-length (ring) "Return the number of elements in the RING." - (car (cdr ring))) + (cadr ring)) (defun ring-index (index head ringlen veclen) "Convert nominal ring index INDEX to an internal index. @@ -95,26 +95,26 @@ VECLEN is the size of the vector in the ring." (defun ring-empty-p (ring) "Return t if RING is empty; nil otherwise." - (zerop (car (cdr ring)))) + (zerop (cadr ring))) (defun ring-size (ring) "Return the size of RING, the maximum number of elements it can contain." - (length (cdr (cdr ring)))) + (length (cddr ring))) (defun ring-copy (ring) "Return a copy of RING." - (let* ((vec (cdr (cdr ring))) - (hd (car ring)) - (ln (car (cdr ring)))) + (let ((vec (cddr ring)) + (hd (car ring)) + (ln (cadr ring))) (cons hd (cons ln (copy-sequence vec))))) (defun ring-insert (ring item) "Insert onto ring RING the item ITEM, as the newest (last) item. If the ring is full, dump the oldest item to make room." - (let* ((vec (cdr (cdr ring))) + (let* ((vec (cddr ring)) (veclen (length vec)) (hd (car ring)) - (ln (car (cdr ring)))) + (ln (cadr ring))) (prog1 (aset vec (mod (+ hd ln) veclen) item) (if (= ln veclen) @@ -128,13 +128,13 @@ numeric, remove the element indexed." (if (ring-empty-p ring) (error "Ring empty") (let* ((hd (car ring)) - (ln (car (cdr ring))) - (vec (cdr (cdr ring))) + (ln (cadr ring)) + (vec (cddr ring)) (veclen (length vec)) (tl (mod (1- (+ hd ln)) veclen)) oldelt) - (if (null index) - (setq index (1- ln))) + (when (null index) + (setq index (1- ln))) (setq index (ring-index index hd ln veclen)) (setq oldelt (aref vec index)) (while (/= index tl) @@ -152,7 +152,9 @@ INDEX need not be <= the ring length; the appropriate modulo operation will be performed." (if (ring-empty-p ring) (error "Accessing an empty ring") - (let* ((hd (car ring)) (ln (car (cdr ring))) (vec (cdr (cdr ring)))) + (let ((hd (car ring)) + (ln (cadr ring)) + (vec (cddr ring))) (aref vec (ring-index index hd ln (length vec)))))) (defun ring-elements (ring) @@ -165,15 +167,12 @@ will be performed." (push (aref vect (mod (+ start var) size)) lst)))) (defun ring-member (ring item) - "Return index of ITEM if on RING, else nil. Comparison via `equal'. -The index is 0-based." - (let ((ind 0) - (len (1- (ring-length ring))) - (memberp nil)) - (while (and (<= ind len) - (not (setq memberp (equal item (ring-ref ring ind))))) - (setq ind (1+ ind))) - (and memberp ind))) + "Return index of ITEM if on RING, else nil. +Comparison is done via `equal'. The index is 0-based." + (catch 'found + (dotimes (ind (ring-length ring) nil) + (when (equal item (ring-ref ring ind)) + (throw 'found ind))))) (defun ring-next (ring item) "Return the next item in the RING, after ITEM. @@ -190,12 +189,12 @@ Raise error if ITEM is not in the RING." (ring-ref ring (ring-minus1 curr-index (ring-length ring))))) (defun ring-insert+extend (ring item &optional grow-p) - "Like ring-insert, but if GROW-P is non-nil, then enlarge ring. + "Like `ring-insert', but if GROW-P is non-nil, then enlarge ring. Insert onto ring RING the item ITEM, as the newest (last) item. If the ring is full, behavior depends on GROW-P: If GROW-P is non-nil, enlarge the ring to accommodate the new item. If GROW-P is nil, dump the oldest item to make room for the new." - (let* ((vec (cdr (cdr ring))) + (let* ((vec (cddr ring)) (veclen (length vec)) (hd (car ring)) (ringlen (ring-length ring))) @@ -218,7 +217,8 @@ If the RING is full, behavior depends on GROW-P: If GROW-P is non-nil, enlarge the ring to accommodate the new ITEM. If GROW-P is nil, dump the oldest item to make room for the new." (let (ind) - (while (setq ind (ring-member ring item)) (ring-remove ring ind))) + (while (setq ind (ring-member ring item)) + (ring-remove ring ind))) (ring-insert+extend ring item grow-p)) (defun ring-convert-sequence-to-ring (seq) @@ -227,13 +227,11 @@ If SEQ is already a ring, return it." (if (ring-p seq) seq (let* ((size (length seq)) - (ring (make-ring size)) - (count 0)) - (while (< count size) - (if (or (ring-empty-p ring) - (not (equal (ring-ref ring 0) (elt seq count)))) - (ring-insert-at-beginning ring (elt seq count))) - (setq count (1+ count))) + (ring (make-ring size))) + (dotimes (count size) + (when (or (ring-empty-p ring) + (not (equal (ring-ref ring 0) (elt seq count)))) + (ring-insert-at-beginning ring (elt seq count)))) ring))) ;;; provide ourself: diff --git a/lisp/emacs-lisp/tcover-ses.el b/lisp/emacs-lisp/tcover-ses.el index 27ddeb25718..a0097ef9052 100644 --- a/lisp/emacs-lisp/tcover-ses.el +++ b/lisp/emacs-lisp/tcover-ses.el @@ -1,6 +1,7 @@ ;;;; testcover-ses.el -- Example use of `testcover' to test "SES" -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 +;; Free Software Foundation, Inc. ;; Author: Jonathan Yavner <jyavner@engineer.com> ;; Maintainer: Jonathan Yavner <jyavner@engineer.com> @@ -26,6 +27,17 @@ (defvar ses-initial-global-parameters) (defvar ses-mode-map) +(declare-function ses-set-curcell "ses") +(declare-function ses-update-cells "ses") +(declare-function ses-load "ses") +(declare-function ses-vector-delete "ses") +(declare-function ses-create-header-string "ses") +(declare-function ses-read-cell "ses") +(declare-function ses-read-symbol "ses") +(declare-function ses-command-hook "ses") +(declare-function ses-jump "ses") + + ;;;Here are some macros that exercise SES. Set `pause' to t if you want the ;;;macros to pause after each step. (let* ((pause nil) diff --git a/lisp/emacs-lisp/tcover-unsafep.el b/lisp/emacs-lisp/tcover-unsafep.el index b999ce63b8c..42c3ebef4e7 100644 --- a/lisp/emacs-lisp/tcover-unsafep.el +++ b/lisp/emacs-lisp/tcover-unsafep.el @@ -111,6 +111,7 @@ ) "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") +(declare-function unsafep-function "unsafep" (fun)) ;;;######################################################################### (defun testcover-unsafep () diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 0fed5962fcb..b11f7ca9d5c 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -356,6 +356,9 @@ This function is called, by name, directly by the C code." "Non-nil if EVENT is a timeout event." (and (listp event) (eq (car event) 'timer-event))) + +(declare-function diary-entry-time "diary-lib" (s)) + ;;;###autoload (defun run-at-time (time repeat function &rest args) "Perform an action at time TIME. diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index fbb39ee66d3..1f696788869 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -286,7 +286,7 @@ enabled." "*If non-nil, only highlight region if marked with S-<move>. When this is non-nil, CUA toggles `transient-mark-mode' on when the region is marked using shifted movement keys, and off when the mark is cleared. -But when the mark was set using \\[cua-set-mark], transient-mark-mode +But when the mark was set using \\[cua-set-mark], Transient Mark mode is not turned on." :type 'boolean :group 'cua) @@ -406,8 +406,8 @@ and after the region marked by the rectangle to search." "Global key used to toggle the cua rectangle mark." :set #'(lambda (symbol value) (set symbol value) - (when (and (boundp 'cua--keymaps-initalized) - cua--keymaps-initalized) + (when (and (boundp 'cua--keymaps-initialized) + cua--keymaps-initialized) (define-key cua-global-keymap value 'cua-set-rectangle-mark) (when (boundp 'cua--rectangle-keymap) @@ -583,35 +583,37 @@ a cons (TYPE . COLOR), then both properties are affected." ;;; Rectangle support is in cua-rect.el -(autoload 'cua-set-rectangle-mark "cua-rect" nil t nil) +(autoload 'cua-set-rectangle-mark "cua-rect" + "Start rectangle at mouse click position." t nil) ;; Stub definitions until it is loaded - -(when (not (featurep 'cua-rect)) - (defvar cua--rectangle) - (setq cua--rectangle nil) - (defvar cua--last-killed-rectangle) - (setq cua--last-killed-rectangle nil)) - - +(defvar cua--rectangle) +(defvar cua--last-killed-rectangle) +(unless (featurep 'cua-rect) + (setq cua--rectangle nil + cua--last-killed-rectangle nil)) + +;; All behind cua--rectangle tests. +(declare-function cua-copy-rectangle "cua-rect" (arg)) +(declare-function cua-cut-rectangle "cua-rect" (arg)) +(declare-function cua--rectangle-left "cua-rect" (&optional val)) +(declare-function cua--delete-rectangle "cua-rect" ()) +(declare-function cua--insert-rectangle "cua-rect" + (rect &optional below paste-column line-count)) +(declare-function cua--rectangle-corner "cua-rect" (&optional advance)) +(declare-function cua--rectangle-assert "cua-rect" ()) ;;; Global Mark support is in cua-gmrk.el (autoload 'cua-toggle-global-mark "cua-gmrk" nil t nil) ;; Stub definitions until cua-gmrk.el is loaded - -(when (not (featurep 'cua-gmrk)) - (defvar cua--global-mark-active) +(defvar cua--global-mark-active) +(unless (featurep 'cua-gmrk) (setq cua--global-mark-active nil)) - -(provide 'cua-base) - -(eval-when-compile - (require 'cua-rect) - (require 'cua-gmrk) - ) +(declare-function cua--insert-at-global-mark "cua-gmrk" (str &optional msg)) +(declare-function cua--global-mark-post-command "cua-gmrk" ()) ;;; Low-level Interface @@ -874,6 +876,8 @@ With numeric prefix arg, copy to register 0-9 instead." (if (fboundp 'cua--cancel-rectangle) (cua--cancel-rectangle))) +(declare-function x-clipboard-yank "../term/x-win" ()) + (defun cua-paste (arg) "Paste last cut or copied region or rectangle. An active region is deleted before executing the command. @@ -918,6 +922,7 @@ If global mark is active, copy from register or one character." (cond (regtxt (cond + ;; This being a cons implies cua-rect is loaded? ((consp regtxt) (cua--insert-rectangle regtxt)) ((stringp regtxt) (insert-for-yank regtxt)) (t (message "Unknown data in register %c" cua--register)))) @@ -954,8 +959,8 @@ If global mark is active, copy from register or one character." (defun cua-paste-pop (arg) "Replace a just-pasted text or rectangle with a different text. -See `yank-pop' for details about the default behaviour. For an alternative -behaviour, see `cua-paste-pop-rotate-temporarily'." +See `yank-pop' for details about the default behavior. For an alternative +behavior, see `cua-paste-pop-rotate-temporarily'." (interactive "P") (cond ((eq last-command 'cua--paste-rectangle) @@ -1225,22 +1230,26 @@ If ARG is the atom `-', scroll upward by nearly full screen." ;; Handle shifted cursor keys and other movement commands. ;; If region is not active, region is activated if key is shifted. - ;; If region is active, region is cancelled if key is unshifted (and region not started with C-SPC). - ;; If rectangle is active, expand rectangle in specified direction and ignore the movement. + ;; If region is active, region is cancelled if key is unshifted + ;; (and region not started with C-SPC). + ;; If rectangle is active, expand rectangle in specified direction and + ;; ignore the movement. ((if window-system + ;; Shortcut for window-system, assuming that input-decode-map is empty. (memq 'shift (event-modifiers (aref (this-single-command-raw-keys) 0))) (or + ;; Check if the final key-sequence was shifted. (memq 'shift (event-modifiers (aref (this-single-command-keys) 0))) - ;; See if raw escape sequence maps to a shifted event, e.g. S-up or C-S-home. - (and (boundp 'local-function-key-map) - local-function-key-map - (let ((ev (lookup-key local-function-key-map - (this-single-command-raw-keys)))) - (and (vector ev) - (symbolp (setq ev (aref ev 0))) - (string-match "S-" (symbol-name ev))))))) + ;; If not, maybe the raw key-sequence was mapped by input-decode-map + ;; to a shifted key (and then mapped down to its unshifted form). + (let* ((keys (this-single-command-raw-keys)) + (ev (lookup-key input-decode-map keys))) + (or (and (vector ev) (memq 'shift (event-modifiers (aref ev 0)))) + ;; Or maybe, the raw key-sequence was not an escape sequence + ;; and was shifted (and then mapped down to its unshifted form). + (memq 'shift (event-modifiers (aref keys 0))))))) (unless mark-active (push-mark-command nil t)) (setq cua--last-region-shifted t) @@ -1326,8 +1335,8 @@ If ARG is the atom `-', scroll upward by nearly full screen." (defvar cua--cua-keys-keymap (make-sparse-keymap)) (defvar cua--prefix-override-keymap (make-sparse-keymap)) (defvar cua--prefix-repeat-keymap (make-sparse-keymap)) -(defvar cua--global-mark-keymap (make-sparse-keymap)) ; Initalized when cua-gmrk.el is loaded -(defvar cua--rectangle-keymap (make-sparse-keymap)) ; Initalized when cua-rect.el is loaded +(defvar cua--global-mark-keymap (make-sparse-keymap)) ; Initialized when cua-gmrk.el is loaded +(defvar cua--rectangle-keymap (make-sparse-keymap)) ; Initialized when cua-rect.el is loaded (defvar cua--region-keymap (make-sparse-keymap)) (defvar cua--ena-cua-keys-keymap nil) @@ -1370,7 +1379,7 @@ If ARG is the atom `-', scroll upward by nearly full screen." (and cua--global-mark-active (not (window-minibuffer-p))))) -(defvar cua--keymaps-initalized nil) +(defvar cua--keymaps-initialized nil) (defun cua--shift-control-prefix (prefix arg) ;; handle S-C-x and S-C-c by emulating the fast double prefix function. @@ -1534,9 +1543,9 @@ shifted movement key, set `cua-highlight-region-shift-only'." (setq mark-even-if-inactive t) (setq highlight-nonselected-windows nil) - (unless cua--keymaps-initalized + (unless cua--keymaps-initialized (cua--init-keymaps) - (setq cua--keymaps-initalized t)) + (setq cua--keymaps-initialized t)) (if cua-mode (progn @@ -1600,7 +1609,7 @@ shifted movement key, set `cua-highlight-region-shift-only'." (setq cua--debug (not cua--debug))) -(provide 'cua) +(provide 'cua-base) ;;; arch-tag: 21fb6289-ba25-4fee-bfdc-f9fb351acf05 ;;; cua-base.el ends here diff --git a/lisp/emulation/cua-gmrk.el b/lisp/emulation/cua-gmrk.el index 6dc4d179d3d..6211a3c3154 100644 --- a/lisp/emulation/cua-gmrk.el +++ b/lisp/emulation/cua-gmrk.el @@ -27,8 +27,6 @@ ;;; Code: -(provide 'cua-gmrk) - (eval-when-compile (require 'cua-base) (require 'cua-rect) @@ -386,5 +384,7 @@ With prefix argument, don't jump to global mark when cancelling it." (setq cua--global-mark-initialized t)) +(provide 'cua-gmrk) + ;;; arch-tag: 553d8076-a91d-48ae-825d-6cb962a5f67f ;;; cua-gmrk.el ends here diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 5c4bc011464..f6b50336815 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -33,12 +33,8 @@ ;;; Code: -(provide 'cua-rect) - (eval-when-compile - (require 'cua-base) - (require 'cua-gmrk) -) + (require 'cua-base)) ;;; Rectangle support @@ -1061,6 +1057,9 @@ The text previously in the rectangle is overwritten by the blanks." ;; (setq cua-save-point (point)) )))) +(declare-function cua--cut-rectangle-to-global-mark "cua-gmrk" (as-text)) +(declare-function cua--copy-rectangle-to-global-mark "cua-gmrk" (as-text)) + (defun cua-copy-rectangle-as-text (&optional arg delete) "Copy rectangle, but store as normal text." (interactive "P") @@ -1491,5 +1490,7 @@ With prefix arg, indent to that column." (setq cua--rectangle-initialized t)) +(provide 'cua-rect) + ;;; arch-tag: b730df53-17b9-4a89-bd63-4a71ec196731 ;;; cua-rect.el ends here diff --git a/lisp/emulation/edt-vt100.el b/lisp/emulation/edt-vt100.el index 4e094a5f703..fbe56c2c341 100644 --- a/lisp/emulation/edt-vt100.el +++ b/lisp/emulation/edt-vt100.el @@ -39,6 +39,8 @@ ;; The following functions are called by the EDT screen width commands defined ;; in edt.el. +(declare-function vt100-wide-mode "../term/vt100" (&optional arg)) + (defun edt-set-term-width-80 () "Set terminal width to 80 columns." (vt100-wide-mode -1)) diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index 4a68e258cb1..1674e7a266b 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -166,28 +166,23 @@ ;;;; VARIABLES and CONSTANTS ;;;; -;; For backward compatibility to Emacs 19. -(or (fboundp 'defgroup) - (defmacro defgroup (&rest rest))) - (defgroup edt nil "Emacs emulating EDT." :prefix "edt-" :group 'emulations) ;; To silence the byte-compiler -(eval-when-compile - (defvar *EDT-keys*) - (defvar edt-default-global-map) - (defvar edt-last-copied-word) - (defvar edt-learn-macro-count) - (defvar edt-orig-page-delimiter) - (defvar edt-orig-transient-mark-mode) - (defvar edt-rect-start-point) - (defvar edt-user-global-map) - (defvar rect-start-point) - (defvar time-string) - (defvar zmacs-region-stays)) +(defvar *EDT-keys*) +(defvar edt-default-global-map) +(defvar edt-last-copied-word) +(defvar edt-learn-macro-count) +(defvar edt-orig-page-delimiter) +(defvar edt-orig-transient-mark-mode) +(defvar edt-rect-start-point) +(defvar edt-user-global-map) +(defvar rect-start-point) +(defvar time-string) +(defvar zmacs-region-stays) ;;; ;;; Version Information @@ -198,11 +193,6 @@ ;;; User Configurable Variables ;;; -;; For backward compatibility to Emacs 19. -(or (fboundp 'defcustom) - (defmacro defcustom (var value doc &rest ignore) - `(defvar ,var ,value ,doc))) - (defcustom edt-keep-current-page-delimiter nil "*Emacs MUST be restarted for a change in value to take effect! Non-nil leaves Emacs value of `page-delimiter' unchanged within EDT @@ -1628,6 +1618,8 @@ Argument NUM is the percentage into the buffer to move." (indent-region (point) (mark) nil) (fill-region (point) (mark)))) + +(declare-function c-mark-function "cc-cmds" ()) ;;; ;;; MARK SECTION WISELY ;;; @@ -2237,7 +2229,10 @@ Optional argument USER-SETUP non-nil means called from function ;; function edt-setup-extra-default-bindings. (define-prefix-command 'edt-user-gold-map) (fset 'edt-user-gold-map (copy-keymap 'edt-default-gold-map)) - (edt-setup-user-bindings) + ;; This is a function that the user can define for custom bindings. + ;; See etc/edt-user.doc. + (if (fboundp 'edt-setup-user-bindings) + (edt-setup-user-bindings)) (edt-select-user-global-map)) (defun edt-select-default-global-map() diff --git a/lisp/emulation/pc-select.el b/lisp/emulation/pc-select.el index a4e304616da..c35044b70ec 100644 --- a/lisp/emulation/pc-select.el +++ b/lisp/emulation/pc-select.el @@ -135,8 +135,8 @@ restored to their original values when PC Selection mode is toggled off.") (unless pc-select-default-key-bindings (let ((lst - ;; This is to avoid confusion with the delete-selection-mode - ;; On simple displays you cant see that a region is active and + ;; This is to avoid confusion with the delete-selection-mode. + ;; On simple displays you can't see that a region is active and ;; will be deleted on the next keypress IMHO especially for ;; copy-region-as-kill this is confusing. ;; The same goes for exchange-point-and-mark @@ -182,7 +182,7 @@ restored to their original values when PC Selection mode is toggled off.") ([prior] . scroll-down-nomark) ;; Next four lines are from Pete Forman. - ([C-down] . forward-paragraph-nomark) ; KNextPara cDn + ([C-down] . forward-paragraph-nomark) ; KNextPara cDn ([C-up] . backward-paragraph-nomark) ; KPrevPara cUp ([S-C-down] . forward-paragraph-mark) ([S-C-up] . backward-paragraph-mark)))) @@ -281,10 +281,17 @@ and `transient-mark-mode'." ;;;; ;; non-interactive ;;;; -(defun ensure-mark() +(defun pc-select-ensure-mark () ;; make sure mark is active ;; test if it is active, if it isn't, set it and activate it - (or mark-active (set-mark-command nil))) + (or mark-active (set-mark-command nil)) + ;; Remember who activated the mark. + (setq mark-active 'pc-select)) + +(defun pc-select-maybe-deactivate-mark () + ;; maybe switch off mark (only if *we* switched it on) + (when (eq mark-active 'pc-select) + (deactivate-mark))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; forward and mark @@ -294,7 +301,7 @@ and `transient-mark-mode'." "Ensure mark is active; move point right ARG characters (left if ARG negative). On reaching end of buffer, stop and signal error." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (forward-char arg)) (defun forward-word-mark (&optional arg) @@ -303,13 +310,13 @@ Normally returns t. If an edge of the buffer is reached, point is left there and nil is returned." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (forward-word arg)) (defun forward-line-mark (&optional arg) "Ensure mark is active; move cursor vertically down ARG lines." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (forward-line arg) (setq this-command 'forward-line) ) @@ -319,7 +326,7 @@ and nil is returned." With argument, do it that many times. Negative arg -N means move backward across N balanced expressions." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (forward-sexp arg)) (defun forward-paragraph-mark (&optional arg) @@ -331,7 +338,7 @@ A line which `paragraph-start' matches either separates paragraphs A paragraph end is the beginning of a line which is not part of the paragraph to which the end of the previous line belongs, or the end of the buffer." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (forward-paragraph arg)) (defun next-line-mark (&optional arg) @@ -350,7 +357,7 @@ a semipermanent goal column to which this command always moves. Then it does not try to move vertically. This goal column is stored in `goal-column', which is nil when there is none." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (with-no-warnings (next-line arg)) (setq this-command 'next-line)) @@ -359,14 +366,14 @@ in `goal-column', which is nil when there is none." With argument ARG not nil or 1, move forward ARG - 1 lines first. If scan reaches end of buffer, stop there without error." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (end-of-line arg) (setq this-command 'end-of-line)) (defun backward-line-mark (&optional arg) "Ensure mark is active; move cursor vertically up ARG lines." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (if (null arg) (setq arg 1)) (forward-line (- arg)) @@ -379,7 +386,7 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll upward. When calling from a program, supply a number as argument or nil." (interactive "P") - (ensure-mark) + (pc-select-ensure-mark) (cond (pc-select-override-scroll-error (condition-case nil (scroll-down arg) (beginning-of-buffer (goto-char (point-min))))) @@ -395,7 +402,7 @@ of the accessible part of the buffer. Don't use this command in Lisp programs! \(goto-char \(point-max)) is faster and avoids clobbering the mark." (interactive "P") - (ensure-mark) + (pc-select-ensure-mark) (let ((size (- (point-max) (point-min)))) (goto-char (if arg (- (point-max) @@ -427,7 +434,7 @@ Don't use this command in Lisp programs! "Deactivate mark; move point right ARG characters \(left if ARG negative). On reaching end of buffer, stop and signal error." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (forward-char arg)) (defun forward-word-nomark (&optional arg) @@ -436,13 +443,13 @@ Normally returns t. If an edge of the buffer is reached, point is left there and nil is returned." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (forward-word arg)) (defun forward-line-nomark (&optional arg) "Deactivate mark; move cursor vertically down ARG lines." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (forward-line arg) (setq this-command 'forward-line) ) @@ -452,7 +459,7 @@ and nil is returned." With argument, do it that many times. Negative arg -N means move backward across N balanced expressions." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (forward-sexp arg)) (defun forward-paragraph-nomark (&optional arg) @@ -464,7 +471,7 @@ A line which `paragraph-start' matches either separates paragraphs A paragraph end is the beginning of a line which is not part of the paragraph to which the end of the previous line belongs, or the end of the buffer." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (forward-paragraph arg)) (defun next-line-nomark (&optional arg) @@ -483,7 +490,7 @@ a semipermanent goal column to which this command always moves. Then it does not try to move vertically. This goal column is stored in `goal-column', which is nil when there is none." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (with-no-warnings (next-line arg)) (setq this-command 'next-line)) @@ -492,14 +499,14 @@ in `goal-column', which is nil when there is none." With argument ARG not nil or 1, move forward ARG - 1 lines first. If scan reaches end of buffer, stop there without error." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (end-of-line arg) (setq this-command 'end-of-line)) (defun backward-line-nomark (&optional arg) "Deactivate mark; move cursor vertically up ARG lines." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (if (null arg) (setq arg 1)) (forward-line (- arg)) @@ -512,7 +519,7 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll upward. When calling from a program, supply a number as argument or nil." (interactive "P") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (cond (pc-select-override-scroll-error (condition-case nil (scroll-down arg) (beginning-of-buffer (goto-char (point-min))))) @@ -528,7 +535,7 @@ of the accessible part of the buffer. Don't use this command in Lisp programs! \(goto-char (point-max)) is faster and avoids clobbering the mark." (interactive "P") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (let ((size (- (point-max) (point-min)))) (goto-char (if arg (- (point-max) @@ -561,14 +568,14 @@ Don't use this command in Lisp programs! "Ensure mark is active; move point left ARG characters (right if ARG negative). On attempt to pass beginning or end of buffer, stop and signal error." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (backward-char arg)) (defun backward-word-mark (&optional arg) "Ensure mark is active; move backward until encountering the end of a word. With argument, do this that many times." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (backward-word arg)) (defun backward-sexp-mark (&optional arg) @@ -576,7 +583,7 @@ With argument, do this that many times." With argument, do it that many times. Negative arg -N means move forward across N balanced expressions." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (backward-sexp arg)) (defun backward-paragraph-mark (&optional arg) @@ -591,7 +598,7 @@ blank line. See `forward-paragraph' for more information." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (backward-paragraph arg)) (defun previous-line-mark (&optional arg) @@ -608,7 +615,7 @@ If you are thinking of using this in a Lisp program, consider using `forward-line' with a negative argument instead. It is usually easier to use and more reliable (no dependence on goal column, etc.)." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (with-no-warnings (previous-line arg)) (setq this-command 'previous-line)) @@ -617,7 +624,7 @@ to use and more reliable (no dependence on goal column, etc.)." With argument ARG not nil or 1, move forward ARG - 1 lines first. If scan reaches end of buffer, stop there without error." (interactive "p") - (ensure-mark) + (pc-select-ensure-mark) (beginning-of-line arg)) @@ -627,7 +634,7 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll downward. When calling from a program, supply a number as argument or nil." (interactive "P") - (ensure-mark) + (pc-select-ensure-mark) (cond (pc-select-override-scroll-error (condition-case nil (scroll-up arg) (end-of-buffer (goto-char (point-max))))) @@ -643,7 +650,7 @@ of the accessible part of the buffer. Don't use this command in Lisp programs! \(goto-char (p\oint-min)) is faster and avoids clobbering the mark." (interactive "P") - (ensure-mark) + (pc-select-ensure-mark) (let ((size (- (point-max) (point-min)))) (goto-char (if arg (+ (point-min) @@ -663,14 +670,14 @@ Don't use this command in Lisp programs! "Deactivate mark; move point left ARG characters (right if ARG negative). On attempt to pass beginning or end of buffer, stop and signal error." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (backward-char arg)) (defun backward-word-nomark (&optional arg) "Deactivate mark; move backward until encountering the end of a word. With argument, do this that many times." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (backward-word arg)) (defun backward-sexp-nomark (&optional arg) @@ -678,7 +685,7 @@ With argument, do this that many times." With argument, do it that many times. Negative arg -N means move forward across N balanced expressions." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (backward-sexp arg)) (defun backward-paragraph-nomark (&optional arg) @@ -693,7 +700,7 @@ blank line. See `forward-paragraph' for more information." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (backward-paragraph arg)) (defun previous-line-nomark (&optional arg) @@ -706,7 +713,7 @@ The command \\[set-goal-column] can be used to create a semipermanent goal column to which this command always moves. Then it does not try to move vertically." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (with-no-warnings (previous-line arg)) (setq this-command 'previous-line)) @@ -715,7 +722,7 @@ Then it does not try to move vertically." With argument ARG not nil or 1, move forward ARG - 1 lines first. If scan reaches end of buffer, stop there without error." (interactive "p") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (beginning-of-line arg)) (defun scroll-up-nomark (&optional arg) @@ -724,7 +731,7 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll downward. When calling from a program, supply a number as argument or nil." (interactive "P") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (cond (pc-select-override-scroll-error (condition-case nil (scroll-up arg) (end-of-buffer (goto-char (point-max))))) @@ -740,7 +747,7 @@ of the accessible part of the buffer. Don't use this command in Lisp programs! \(goto-char (point-min)) is faster and avoids clobbering the mark." (interactive "P") - (setq mark-active nil) + (pc-select-maybe-deactivate-mark) (let ((size (- (point-max) (point-min)))) (goto-char (if arg (+ (point-min) @@ -968,21 +975,5 @@ but before calling PC Selection mode): (setq pc-select-key-bindings-alist nil pc-select-saved-settings-alist nil)))) - -;;;###autoload -(defcustom pc-selection-mode nil - "Toggle PC Selection mode. -Change mark behavior to emulate Motif, MAC or MS-Windows cut and paste style, -and cursor movement commands. -This mode enables Delete Selection mode and Transient Mark mode. -Setting this variable directly does not take effect; -you must modify it using \\[customize] or \\[pc-selection-mode]." - :set (lambda (symbol value) - (pc-selection-mode (if value 1 -1))) - :initialize 'custom-initialize-default - :type 'boolean - :group 'pc-select - :require 'pc-select) - -;;; arch-tag: 10697b70-ae07-4f3e-ad23-7814a3f418c2 +;; arch-tag: 10697b70-ae07-4f3e-ad23-7814a3f418c2 ;;; pc-select.el ends here diff --git a/lisp/emulation/tpu-edt.el b/lisp/emulation/tpu-edt.el index 425ac450fae..c5ae34e0f07 100644 --- a/lisp/emulation/tpu-edt.el +++ b/lisp/emulation/tpu-edt.el @@ -273,7 +273,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) ;; we use picture-mode functions (require 'picture) @@ -1367,6 +1366,9 @@ The search is performed in the current direction." ;; tpu-search-forward (t) tpu-search-reverse (t) ;; tpu-search-forward-exit (t) tpu-search-backward-exit (t) +(declare-function tpu-emacs-search "tpu-edt") +(declare-function tpu-emacs-rev-search "tpu-edt") + (defun tpu-set-search (&optional arg) "Set the search functions and set the search direction to the current direction. If an argument is specified, don't set the search direction." @@ -2432,7 +2434,10 @@ If FILE is nil, try to load a default file. The default file names are (if (eq tpu-global-map parent) (set-keymap-parent map (keymap-parent parent)) (setq map parent))))) - (ignore-errors (ad-disable-regexp "\\`tpu-")) + ;; Only has an effect if the advice in tpu-extras has been activated. + (condition-case nil + (with-no-warnings (ad-disable-regexp "\\`tpu-")) + (error nil)) (setq tpu-edt-mode nil)) diff --git a/lisp/emulation/vi.el b/lisp/emulation/vi.el index 81ad04b60d9..de7bcffdf0e 100644 --- a/lisp/emulation/vi.el +++ b/lisp/emulation/vi.el @@ -1375,6 +1375,8 @@ The following CHAR will be the name for the command or macro." (setq char (read-char)) (vi-ask-for-info char)))) +(declare-function c-mark-function "cc-cmds" ()) + (defun vi-mark-region (arg region) "Mark region appropriately. The next char REGION is d(efun),s(-exp),b(uffer), p(aragraph), P(age), f(unction in C/Pascal etc.), w(ord), e(nd of sentence), diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 5e13edb9495..8603169819f 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -27,7 +27,6 @@ ;;; Code: (provide 'viper-cmd) -(require 'advice) ;; Compiler pacifier (defvar viper-minibuffer-current-face) @@ -48,23 +47,6 @@ (defvar initial) (defvar undo-beg-posn) (defvar undo-end-posn) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) - (or (featurep 'viper-mous) - (load "viper-mous.el" nil nil 'nosuffix)) - (or (featurep 'viper-macs) - (load "viper-macs.el" nil nil 'nosuffix)) - (or (featurep 'viper-ex) - (load "viper-ex.el" nil nil 'nosuffix)) - ))) ;; end pacifier @@ -3097,6 +3079,9 @@ On reaching beginning of line, stop and signal error." (setq this-command 'next-line) (if com (viper-execute-com 'viper-next-line val com)))) +(declare-function widget-type "wid-edit" (widget)) +(declare-function widget-button-press "wid-edit" (pos &optional event)) +(declare-function viper-set-hooks "viper" ()) (defun viper-next-line-at-bol (arg) "Next line at beginning of line. diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index caeecd12c8a..ccc06e0b938 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -47,12 +47,8 @@ (if noninteractive (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) + (load "viper-cmd.el" nil t 'nosuffix)) ))) ;; end pacifier diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 1b1e07a0a0c..539a561bb5b 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -26,8 +26,6 @@ ;;; Code: -(provide 'viper-init) - ;; compiler pacifier (defvar mark-even-if-inactive) (defvar quail-mode) @@ -429,15 +427,11 @@ delete the text being replaced, as in standard Vi." "*Cursor color when Viper is in Replace state." :type 'string :group 'viper) -(if (fboundp 'make-variable-frame-local) - (make-variable-frame-local 'viper-replace-overlay-cursor-color)) (defcustom viper-insert-state-cursor-color "Green" "Cursor color when Viper is in insert state." :type 'string :group 'viper) -(if (fboundp 'make-variable-frame-local) - (make-variable-frame-local 'viper-insert-state-cursor-color)) ;; viper-emacs-state-cursor-color doesn't work well. Causes cursor colors to be ;; confused in some cases. So, this var is nulled for now. @@ -446,13 +440,17 @@ delete the text being replaced, as in standard Vi." "Cursor color when Viper is in Emacs state." :type 'string :group 'viper) -(if (fboundp 'make-variable-frame-local) - (make-variable-frame-local 'viper-emacs-state-cursor-color)) ;; internal var, used to remember the default cursor color of emacs frames (defvar viper-vi-state-cursor-color nil) + (if (fboundp 'make-variable-frame-local) - (make-variable-frame-local 'viper-vi-state-cursor-color)) + (mapc 'make-variable-frame-local + '(viper-replace-overlay-cursor-color + viper-insert-state-cursor-color + viper-emacs-state-cursor-color + viper-vi-state-cursor-color))) + (viper-deflocalvar viper-replace-overlay nil "") (put 'viper-replace-overlay 'permanent-local t) @@ -1025,6 +1023,9 @@ Should be set in `~/.viper' file." (setq cursor-type '(bar . 2)))) +(provide 'viper-init) + + ;; Local Variables: ;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) ;; End: diff --git a/lisp/emulation/viper-keym.el b/lisp/emulation/viper-keym.el index 0e502720f5e..85a94075720 100644 --- a/lisp/emulation/viper-keym.el +++ b/lisp/emulation/viper-keym.el @@ -26,8 +26,6 @@ ;;; Code: -(provide 'viper-keym) - ;; compiler pacifier (defvar viper-always) (defvar viper-current-state) @@ -35,19 +33,13 @@ (defvar viper-expert-level) (defvar viper-ex-style-editing) (defvar viper-ex-style-motion) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - ))) ;; end pacifier (require 'viper-util) +(declare-function viper-ex "viper-ex" (arg &optional string)) +(declare-function viper-normalize-minor-mode-map-alist "viper-cmd" ()) +(declare-function viper-set-mode-vars-for "viper-cmd" (state)) ;;; Variables @@ -702,6 +694,9 @@ form ((key . function) (key . function) ... )." alist)) +(provide 'viper-keym) + + ;;; Local Variables: ;;; eval: (put 'viper-deflocalvar 'lisp-indent-hook 'defun) ;;; End: diff --git a/lisp/emulation/viper-macs.el b/lisp/emulation/viper-macs.el index 788feaf86e6..6eb7687c4e6 100644 --- a/lisp/emulation/viper-macs.el +++ b/lisp/emulation/viper-macs.el @@ -39,14 +39,8 @@ (if noninteractive (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) - (or (featurep 'viper-keym) - (load "viper-keym.el" nil nil 'nosuffix)) - (or (featurep 'viper-mous) - (load "viper-mous.el" nil nil 'nosuffix)) (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) + (load "viper-cmd.el" nil t 'nosuffix)) ))) ;; end pacifier diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 7a47d321890..dd727cd5f84 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -42,10 +42,8 @@ (if noninteractive (eval-when-compile (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-util) - (load "viper-util.el" nil nil 'nosuffix)) (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) + (load "viper-cmd.el" nil t 'nosuffix)) ))) ;; end pacifier diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index c757eb63aef..87bf5235b81 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -44,12 +44,6 @@ (require 'ring) -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-init) - (load "viper-init.el" nil nil 'nosuffix)) - ))) ;; end pacifier (require 'viper-init) @@ -380,6 +374,8 @@ +(declare-function viper-forward-Word "viper-cmd" (arg)) + ;;; Support for :e, :r, :w file globbing ;; Glob the file spec. diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index 65d40e8bad7..bb3e4eb583d 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -297,28 +297,15 @@ ;;; Code: -(require 'advice) -(require 'ring) - ;; compiler pacifier (defvar mark-even-if-inactive) (defvar quail-mode) (defvar viper-expert-level) (defvar viper-mode-string) (defvar viper-major-mode-modifier-list) - -;; loading happens only in non-interactive compilation -;; in order to spare non-viperized emacs from being viperized -(if noninteractive - (eval-when-compile - (let ((load-path (cons (expand-file-name ".") load-path))) - (or (featurep 'viper-init) - (load "viper-init.el" nil nil 'nosuffix)) - (or (featurep 'viper-cmd) - (load "viper-cmd.el" nil nil 'nosuffix)) - ))) ;; end pacifier +(require 'advice) (require 'viper-init) (require 'viper-keym) diff --git a/lisp/erc/ChangeLog b/lisp/erc/ChangeLog index 929df097790..bd20dfbed45 100644 --- a/lisp/erc/ChangeLog +++ b/lisp/erc/ChangeLog @@ -1,3 +1,41 @@ +2007-12-01 Glenn Morris <rgm@gnu.org> + + * erc-backend.el (erc-server-send-ping): Move after definition of + erc-server-send. + + * erc.el (iswitchb-temp-buflist, iswitchb-read-buffer) + (erc-controls-strip): Declare for compiler. + (erc-iswitchb): Don't require iswitchb when compiling. Test + iswitchb-mode is bound. + +2007-11-30 Dan Nicolaescu <dann@ics.uci.edu> + + * erc.el (open-ssl-stream, open-tls-stream, erc-network-name): + Declare as functions. + +2007-11-29 Giorgos Keramidas <keramida@ceid.upatras.gr> (tiny change) + + * erc-backend.el, erc.el: + Parse 307 (nick has identified) responses. + +2007-11-15 Juanma Barranquero <lekktu@gmail.com> + + * erc.el (erc-open): + * erc-backend.el (define-erc-response-handler): + * erc-log.el (log): + * erc-match.el (erc-log-matches): Fix typos in docstrings. + +2007-11-11 Michael Olson <mwolson@gnu.org> + + * erc-autoaway.el (erc-autoaway-possibly-set-away): + * erc-netsplit.el (erc-netsplit-timer): + * erc-notify.el (erc-notify-timer): + * erc-track.el (erc-user-is-active): Only run if we have + successfully established a connection to the server and have + logged in. I suspect that sending messages too soon may make some + IRC servers not respond well, particularly when the network + connection is iffy or subject to traffic-shaping. + 2007-11-01 Michael Olson <mwolson@gnu.org> * erc-compat.el (erc-set-write-file-functions): New compatibility diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el index c70beb112e2..4c841387d7f 100644 --- a/lisp/erc/erc-autoaway.el +++ b/lisp/erc/erc-autoaway.el @@ -248,7 +248,8 @@ exceeds `erc-autoaway-idle-seconds'." ;; A test for (erc-server-process-alive) is not necessary, because ;; this function is called from `erc-timer-hook', which is called ;; whenever the server sends something to the client. - (when (and erc-auto-set-away + (when (and erc-server-connected + erc-auto-set-away (not erc-autoaway-caused-away) (erc-autoaway-some-open-server-buffer)) (let ((idle-time (erc-time-diff erc-autoaway-last-sent-time diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 4e250490e9c..c0f4205c012 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -461,27 +461,6 @@ Currently this is called by `erc-send-input'." (upcase-word 1) (buffer-string))) -(defun erc-server-send-ping (buf) - "Send a ping to the IRC server buffer in BUF. -Additionally, detect whether the IRC process has hung." - (if (buffer-live-p buf) - (with-current-buffer buf - (if (and erc-server-send-ping-timeout - (> - (erc-time-diff (erc-current-time) - erc-server-last-received-time) - erc-server-send-ping-timeout)) - (progn - ;; if the process is hung, kill it - (setq erc-server-timed-out t) - (delete-process erc-server-process)) - (erc-server-send (format "PING %.0f" (erc-current-time))))) - ;; remove timer if the server buffer has been killed - (let ((timer (assq buf erc-server-ping-timer-alist))) - (when timer - (erc-cancel-timer (cdr timer)) - (setcdr timer nil))))) - (defun erc-server-setup-periodical-ping (buffer) "Set up a timer to periodically ping the current server. The current buffer is given by BUFFER." @@ -775,6 +754,27 @@ protection algorithm." (message "ERC: No process running") nil))) +(defun erc-server-send-ping (buf) + "Send a ping to the IRC server buffer in BUF. +Additionally, detect whether the IRC process has hung." + (if (buffer-live-p buf) + (with-current-buffer buf + (if (and erc-server-send-ping-timeout + (> + (erc-time-diff (erc-current-time) + erc-server-last-received-time) + erc-server-send-ping-timeout)) + (progn + ;; if the process is hung, kill it + (setq erc-server-timed-out t) + (delete-process erc-server-process)) + (erc-server-send (format "PING %.0f" (erc-current-time))))) + ;; remove timer if the server buffer has been killed + (let ((timer (assq buf erc-server-ping-timer-alist))) + (when timer + (erc-cancel-timer (cdr timer)) + (setcdr timer nil))))) + ;; From Circe (defun erc-server-send-queue (buffer) "Send messages in `erc-server-flood-queue'. @@ -1018,13 +1018,13 @@ NAME is the response name as sent by the server (see the IRC RFC for meanings). This creates: - - a hook variable `erc-server-NAME-functions' initialised to `erc-server-NAME'. + - a hook variable `erc-server-NAME-functions' initialized to `erc-server-NAME'. - a function `erc-server-NAME' with body FN-BODY. If ALIASES is non-nil, each alias in ALIASES is `defalias'ed to `erc-server-NAME'. Alias hook variables are created as `erc-server-ALIAS-functions' and -initialised to the same default value as `erc-server-NAME-functions'. +initialized to the same default value as `erc-server-NAME-functions'. FN-BODY is the body of `erc-server-NAME' it may refer to the two function arguments PROC and PARSED. @@ -1564,6 +1564,16 @@ See `erc-display-server-message'." nil (erc-display-message parsed 'notice 'active 's306 ?m (erc-response.contents parsed))) +(define-erc-response-handler (307) + "Display nick-identified message." nil + (multiple-value-bind (nick user message) + (cdr (erc-response.command-args parsed)) + (erc-display-message + parsed 'notice 'active 's307 + ?n nick + ?m (mapconcat 'identity (cddr (erc-response.command-args parsed)) + " ")))) + (define-erc-response-handler (311 314) "WHOIS/WHOWAS notices." nil (let ((fname (erc-response.contents parsed)) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 8b5e07a383e..fe3e703f554 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -224,8 +224,8 @@ format is defined through a formatting function on Since automatic logging is not always a Good Thing (especially if people say things in different coding systems), you can turn logging -behaviour on and off with the variable `erc-enable-logging', which can -also be a predicate function. To only log when you are not set away, use: +behavior on and off with the variable `erc-enable-logging', which can +also be a predicate function. To only log when you are not set away, use: \(setq erc-enable-logging (lambda (buffer) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index c147b6566f8..a4752588ebd 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -530,11 +530,11 @@ Use this defun with `erc-insert-modify-hook'." (defun erc-log-matches (match-type nickuserhost message) "Log matches in a separate buffer, determined by MATCH-TYPE. -The behaviour of this function is controlled by the variables -`erc-log-matches-types-alist' and `erc-log-matches-flag'. Specify the -match types which should be logged in the former, and -deactivate/activate match logging in the latter. See -`erc-log-match-format'." +The behavior of this function is controlled by the variables +`erc-log-matches-types-alist' and `erc-log-matches-flag'. +Specify the match types which should be logged in the former, +and deactivate/activate match logging in the latter. +See `erc-log-match-format'." (let ((match-buffer-name (cdr (assq match-type erc-log-matches-types-alist))) (nick (nth 0 (erc-parse-user nickuserhost)))) diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index 83bc0dffc0c..b20b7ad738b 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el @@ -173,13 +173,14 @@ join from that split has been detected or not.") (defun erc-netsplit-timer (now) "Clean cruft from `erc-netsplit-list' older than 10 minutes." - (dolist (elt erc-netsplit-list) - (when (> (erc-time-diff (cadr elt) now) 600) - (when erc-netsplit-debug - (erc-display-message - nil 'notice (current-buffer) - (concat "Netsplit: Removing " (car elt)))) - (setq erc-netsplit-list (delq elt erc-netsplit-list))))) + (when erc-server-connected + (dolist (elt erc-netsplit-list) + (when (> (erc-time-diff (cadr elt) now) 600) + (when erc-netsplit-debug + (erc-display-message + nil 'notice (current-buffer) + (concat "Netsplit: Removing " (car elt)))) + (setq erc-netsplit-list (delq elt erc-netsplit-list)))))) ;;;###autoload (defun erc-cmd-WHOLEFT () diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 9216631a9b4..34556a00d6c 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -111,7 +111,8 @@ changes." ;;;; Timer handler (defun erc-notify-timer (now) - (when (and erc-notify-list + (when (and erc-server-connected + erc-notify-list (> (erc-time-diff erc-last-ison-time now) erc-notify-interval)) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index ad3eaf73a4b..15de2094214 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -665,8 +665,9 @@ only consider active buffers visible.") (defun erc-user-is-active (&rest ignore) "Set `erc-buffer-activity'." - (setq erc-buffer-activity (erc-current-time)) - (erc-track-modified-channels)) + (when erc-server-connected + (setq erc-buffer-activity (erc-current-time)) + (erc-track-modified-channels))) (defun erc-track-get-buffer-window (buffer frame-param) (if (eq frame-param 'selected-visible) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index fab8f7ca1b9..e4e9268bfbe 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1693,6 +1693,11 @@ nil." (put 'erc-with-all-buffers-of-server 'lisp-indent-function 1) (put 'erc-with-all-buffers-of-server 'edebug-form-spec '(form form body)) +;; (iswitchb-mode) will autoload iswitchb.el +(defvar iswitchb-temp-buflist) +(declare-function iswitchb-read-buffer "iswitchb" + (prompt &optional default require-match start matches-set)) + (defun erc-iswitchb (&optional arg) "Use `iswitchb-read-buffer' to prompt for a ERC buffer to switch to. When invoked with prefix argument, use all erc buffers. Without prefix @@ -1703,9 +1708,7 @@ If `erc-track-mode' is in enabled, put the last element of Due to some yet unresolved reason, global function `iswitchb-mode' needs to be active for this function to work." (interactive "P") - (eval-when-compile - (require 'iswitchb)) - (let ((enabled iswitchb-mode)) + (let ((enabled (bound-and-true-p iswitchb-mode))) (or enabled (iswitchb-mode 1)) (unwind-protect (let ((iswitchb-make-buflist-hook @@ -1924,7 +1927,7 @@ already connected and just create a separate buffer for the new target CHANNEL. Use PASSWD as user password on the server. If TGT-LIST is -non-nil, use it to initialise `erc-default-recipients'. +non-nil, use it to initialize `erc-default-recipients'. Returns the buffer for the given server or channel." (let ((server-announced-name (when (and (boundp 'erc-session-server) @@ -2165,6 +2168,8 @@ Arguments are the same as for `erc'." (defalias 'erc-select-ssl 'erc-ssl) +(declare-function open-ssl-stream "ext:ssl" (name buffer host service)) + (defun erc-open-ssl-stream (name buffer host port) "Open an SSL stream to an IRC server. The process will be given the name NAME, its target buffer will be @@ -2189,6 +2194,8 @@ Arguments are the same as for `erc'." (let ((erc-server-connect-function 'erc-open-tls-stream)) (apply 'erc r))) +(declare-function open-tls-stream "tls" (name buffer host port)) + (defun erc-open-tls-stream (name buffer host port) "Open an TLS stream to an IRC server. The process will be given the name NAME, its target buffer will be @@ -2225,6 +2232,8 @@ but you won't see it. WARNING: Do not set this variable directly! Instead, use the function `erc-toggle-debug-irc-protocol' to toggle its value.") +(declare-function erc-network-name "erc-networks" ()) + (defun erc-log-irc-protocol (string &optional outbound) "Append STRING to the buffer *erc-protocol*. @@ -5955,6 +5964,9 @@ if `erc-away' is non-nil." (cond (lag (format "lag:%.0f" lag)) (t "")))) +;; erc-goodies is required at end of this file. +(declare-function erc-controls-strip "erc-goodies" (str)) + (defun erc-update-mode-line-buffer (buffer) "Update the mode line in a single ERC buffer BUFFER." (with-current-buffer buffer @@ -6205,6 +6217,7 @@ All windows are opened in the current frame." (s303 . "Is online: %n") (s305 . "%m") (s306 . "%m") + (s307 . "%n %m") (s311 . "%n is %f (%u@%h)") (s312 . "%n is/was on server %s (%c)") (s313 . "%n is an IRC operator") diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el index 8ecc335523b..dd61dac0594 100644 --- a/lisp/eshell/em-alias.el +++ b/lisp/eshell/em-alias.el @@ -22,17 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-alias) - -(eval-when-compile (require 'esh-maint)) -(require 'eshell) - -(defgroup eshell-alias nil - "Command aliases allow for easy definition of alternate commands." - :tag "Command aliases" - ;; :link '(info-link "(eshell)Command aliases") - :group 'eshell-module) - ;;; Commentary: ;; Command aliases greatly simplify the definition of new commands. @@ -62,19 +51,8 @@ ;; ;; Aliases are written to disk immediately after being defined or ;; deleted. The filename in which they are kept is defined by the -;; following variable: +;; variable eshell-aliases-file. -(defcustom eshell-aliases-file (concat eshell-directory-name "alias") - "*The file in which aliases are kept. -Whenever an alias is defined by the user, using the `alias' command, -it will be written to this file. Thus, alias definitions (and -deletions) are always permanent. This approach was chosen for the -sake of simplicity, since that's pretty much the only benefit to be -gained by using this module." - :type 'file - :group 'eshell-alias) - -;;; ;; The format of this file is quite basic. It specifies the alias ;; definitions in almost exactly the same way that the user entered ;; them, minus any argument quoting (since interpolation is not done @@ -102,19 +80,12 @@ gained by using this module." ;; mispelled command, once a given tolerance threshold has been ;; reached. -(defcustom eshell-bad-command-tolerance 3 - "*The number of failed commands to ignore before creating an alias." - :type 'integer - ;; :link '(custom-manual "(eshell)Auto-correction of bad commands") - :group 'eshell-alias) - -;;; -;; Whenever the same bad command name is encountered this many times, -;; the user will be prompted in the minibuffer to provide an alias -;; name. An alias definition will then be created which will result -;; in an equal call to the correct name. In this way, Eshell -;; gradually learns about the commands that the user mistypes -;; frequently, and will automatically correct them! +;; Whenever the same bad command name is encountered +;; `eshell-bad-command-tolerance' times, the user will be prompted in +;; the minibuffer to provide an alias name. An alias definition will +;; then be created which will result in an equal call to the correct +;; name. In this way, Eshell gradually learns about the commands that +;; the user mistypes frequently, and will automatically correct them! ;; ;; Note that a '$*' is automatically appended at the end of the alias ;; definition, so that entering it is unnecessary when specifying the @@ -122,6 +93,32 @@ gained by using this module." ;;; Code: +(eval-when-compile + (require 'esh-util)) +(require 'eshell) + +(defgroup eshell-alias nil + "Command aliases allow for easy definition of alternate commands." + :tag "Command aliases" + ;; :link '(info-link "(eshell)Command aliases") + :group 'eshell-module) + +(defcustom eshell-aliases-file (concat eshell-directory-name "alias") + "*The file in which aliases are kept. +Whenever an alias is defined by the user, using the `alias' command, +it will be written to this file. Thus, alias definitions (and +deletions) are always permanent. This approach was chosen for the +sake of simplicity, since that's pretty much the only benefit to be +gained by using this module." + :type 'file + :group 'eshell-alias) + +(defcustom eshell-bad-command-tolerance 3 + "*The number of failed commands to ignore before creating an alias." + :type 'integer + ;; :link '(custom-manual "(eshell)Auto-correction of bad commands") + :group 'eshell-alias) + (defcustom eshell-alias-load-hook '(eshell-alias-initialize) "*A hook that gets run when `eshell-alias' is loaded." :type 'hook @@ -180,6 +177,9 @@ command, which will automatically write them to the file named by (eshell-write-aliases-list)) nil) +(defvar pcomplete-stub) +(autoload 'pcomplete-here "pcomplete") + (defun pcomplete/eshell-mode/alias () "Completion function for Eshell's `alias' command." (pcomplete-here (eshell-alias-completions pcomplete-stub))) @@ -274,5 +274,7 @@ These are all the command aliases which begin with NAME." eshell-prevent-alias-expansion)))) (eshell-parse-command alias)))))))))) +(provide 'em-alias) + ;;; arch-tag: 8b018fc1-4e07-4ccc-aa73-c0a1ba361f82 ;;; em-alias.el ends here diff --git a/lisp/eshell/em-banner.el b/lisp/eshell/em-banner.el index 17d930a055d..b9642f41df6 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -22,18 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-banner) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-banner nil - "This sample module displays a welcome banner at login. -It exists so that others wishing to create their own Eshell extension -modules may have a simple template to begin with." - :tag "Login banner" - ;; :link '(info-link "(eshell)Login banner") - :group 'eshell-module) - ;;; Commentary: ;; There is nothing to be done or configured in order to use this @@ -51,6 +39,23 @@ modules may have a simple template to begin with." ;; In this case, it allows the user to change the string which ;; displays at login time. +;;; Code: + +(eval-when-compile + (require 'cl) + (require 'esh-mode) + (require 'eshell)) + +(require 'esh-util) + +(defgroup eshell-banner nil + "This sample module displays a welcome banner at login. +It exists so that others wishing to create their own Eshell extension +modules may have a simple template to begin with." + :tag "Login banner" + ;; :link '(info-link "(eshell)Login banner") + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-banner-message "Welcome to the Emacs shell\n\n" @@ -61,10 +66,6 @@ This can be any sexp, and should end with at least two newlines." (put 'eshell-banner-message 'risky-local-variable t) -;;; Code: - -(require 'esh-util) - (defcustom eshell-banner-load-hook '(eshell-banner-initialize) "*A list of functions to run when `eshell-banner' is loaded." :type 'hook @@ -90,5 +91,7 @@ This can be any sexp, and should end with at least two newlines." (goto-char (point-min)) (looking-at msg))) +(provide 'em-banner) + ;;; arch-tag: e738b4ef-8671-42ae-a757-291779b92491 ;;; em-banner.el ends here diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index 458f6918de4..57f9a094141 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -22,19 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-basic) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-basic nil - "The \"basic\" code provides a set of convenience functions which -are traditionally considered shell builtins. Since all of the -functionality provided by them is accessible through Lisp, they are -not really builtins at all, but offer a command-oriented way to do the -same thing." - :tag "Basic shell commands" - :group 'eshell-module) - ;;; Commentary: ;; There are very few basic Eshell commands -- so-called builtins. @@ -48,14 +35,6 @@ same thing." ;; echo as an argument), or whether it should try to act like a normal ;; shell echo, and always result in a flat string being returned. -(defcustom eshell-plain-echo-behavior nil - "*If non-nil, `echo' tries to behave like an ordinary shell echo. -This comes at some detriment to Lisp functionality. However, the Lisp -equivalent of `echo' can always be achieved by using `identity'." - :type 'boolean - :group 'eshell-basic) - -;;; ;; An example of the difference is the following: ;; ;; echo Hello world @@ -83,8 +62,27 @@ equivalent of `echo' can always be achieved by using `identity'." ;;; Code: +(eval-when-compile + (require 'esh-util)) + (require 'esh-opt) +(defgroup eshell-basic nil + "The \"basic\" code provides a set of convenience functions which +are traditionally considered shell builtins. Since all of the +functionality provided by them is accessible through Lisp, they are +not really builtins at all, but offer a command-oriented way to do the +same thing." + :tag "Basic shell commands" + :group 'eshell-module) + +(defcustom eshell-plain-echo-behavior nil + "*If non-nil, `echo' tries to behave like an ordinary shell echo. +This comes at some detriment to Lisp functionality. However, the Lisp +equivalent of `echo' can always be achieved by using `identity'." + :type 'boolean + :group 'eshell-basic) + ;;; Functions: (defun eshell-echo (args &optional output-newline) @@ -180,8 +178,7 @@ or `eshell-printn' for display." "Warning: umask changed for all new files created by Emacs.\n")) nil)) -(eval-when-compile - (defvar print-func)) +(provide 'em-basic) ;;; arch-tag: 385a31b1-cb95-46f0-9829-9d352ee77db8 ;;; em-basic.el ends here diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 7247033a235..b5f666a6bf6 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -22,18 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-cmpl) - -(eval-when-compile (require 'esh-maint)) -(require 'esh-util) - -(defgroup eshell-cmpl nil - "This module provides a programmable completion function bound to -the TAB key, which allows for completing command names, file names, -variable names, arguments, etc." - :tag "Argument completion" - :group 'eshell-module) - ;;; Commentary: ;; Eshell, by using the pcomplete package, provides a full @@ -82,6 +70,19 @@ variable names, arguments, etc." ;; This only works well if the completion function has provided Eshell ;; with sufficient pointers to locate the relevant help text. +;;; Code: + +(eval-when-compile + (require 'eshell)) +(require 'esh-util) + +(defgroup eshell-cmpl nil + "This module provides a programmable completion function bound to +the TAB key, which allows for completing command names, file names, +variable names, arguments, etc." + :tag "Argument completion" + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-cmpl-load-hook '(eshell-cmpl-initialize) @@ -296,7 +297,7 @@ to writing a completion function." (define-key eshell-mode-map [tab] 'pcomplete) (define-key eshell-mode-map [(control ?i)] 'pcomplete) ;; jww (1999-10-19): Will this work on anything but X? - (if (eshell-under-xemacs-p) + (if (featurep 'xemacs) (define-key eshell-mode-map [iso-left-tab] 'pcomplete-reverse) (define-key eshell-mode-map [(shift iso-lefttab)] 'pcomplete-reverse) (define-key eshell-mode-map [(shift control ?i)] 'pcomplete-reverse)) @@ -448,7 +449,7 @@ to writing a completion function." (all-completions filename obarray 'functionp)) completions))))))) -;;; Code: +(provide 'em-cmpl) ;;; arch-tag: 0e914699-673a-45f8-8cbf-82e1dbc571bc ;;; em-cmpl.el ends here diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 02556661b1b..8a1e81621bc 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -22,20 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-dirs) - -(eval-when-compile (require 'esh-maint)) -(require 'eshell) - -(defgroup eshell-dirs nil - "Directory navigation involves changing directories, examining the -current directory, maintaining a directory stack, and also keeping -track of a history of the last directory locations the user was in. -Emacs does provide standard Lisp definitions of `pwd' and `cd', but -they lack somewhat in feel from the typical shell equivalents." - :tag "Directory navigation" - :group 'eshell-module) - ;;; Commentary: ;; The only special feature that Eshell offers in the last-dir-ring. @@ -57,9 +43,21 @@ they lack somewhat in feel from the typical shell equivalents." ;; Eshell sessions. It is a separate mechanism from `pushd' and ;; `popd', and the two may be used at the same time. +;;; Code: + +(require 'eshell) (require 'ring) (require 'esh-opt) +(defgroup eshell-dirs nil + "Directory navigation involves changing directories, examining the +current directory, maintaining a directory stack, and also keeping +track of a history of the last directory locations the user was in. +Emacs does provide standard Lisp definitions of `pwd' and `cd', but +they lack somewhat in feel from the typical shell equivalents." + :tag "Directory navigation" + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-dirs-load-hook '(eshell-dirs-initialize) @@ -566,7 +564,7 @@ in the minibuffer: (write-region (point-min) (point-max) file nil 'no-message)))))))) -;;; Code: +(provide 'em-dirs) ;;; arch-tag: 1e9c5a95-f1bd-45f8-ad36-55aac706e787 ;;; em-dirs.el ends here diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 2e95aaefae0..b08ddd77e19 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -22,19 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -;;; Code: - -(provide 'em-glob) - -(eval-when-compile (require 'esh-maint)) -(require 'esh-util) - -(defgroup eshell-glob nil - "This module provides extended globbing syntax, similar what is used -by zsh for filename generation." - :tag "Extended filename globbing" - :group 'eshell-module) - ;;; Commentary: ;; The globbing code used by Eshell closely follows the syntax used by @@ -63,6 +50,17 @@ by zsh for filename generation." ;; owned by the user 'johnw'. See [Value modifiers and predicates], ;; for more information about argument predication. +;;; Code: + +(eval-when-compile (require 'eshell)) +(require 'esh-util) + +(defgroup eshell-glob nil + "This module provides extended globbing syntax, similar what is used +by zsh for filename generation." + :tag "Extended filename globbing" + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-glob-load-hook '(eshell-glob-initialize) @@ -356,5 +354,7 @@ the form: (eshell-glob-entries (car rdirs) globs recurse-p) (setq rdirs (cdr rdirs))))) +(provide 'em-glob) + ;;; arch-tag: d0548f54-fb7c-4978-a88e-f7c26f7f68ca ;;; em-glob.el ends here diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 88e15423956..2dd2b31d34a 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -22,16 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-hist) - -(eval-when-compile (require 'esh-maint)) -(require 'eshell) - -(defgroup eshell-hist nil - "This module provides command history management." - :tag "History list management" - :group 'eshell-module) - ;;; Commentary: ;; Eshell's history facility imitates the syntax used by bash @@ -70,6 +60,12 @@ (require 'ring) (require 'esh-opt) (require 'em-pred) +(require 'eshell) + +(defgroup eshell-hist nil + "This module provides command history management." + :tag "History list management" + :group 'eshell-module) ;;; User Variables: @@ -988,5 +984,7 @@ If N is negative, search backwards for the -Nth previous match." (isearch-done) (eshell-send-input)) +(provide 'em-hist) + ;;; arch-tag: 1a847333-f864-4b96-9acd-b549d620b6c6 ;;; em-hist.el ends here diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index d6b4f3aed29..01a6bb87a1f 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -22,9 +22,16 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-ls) +;;; Commentary: + +;; Most of the command switches recognized by GNU's ls utility are +;; supported ([(fileutils)ls invocation]). -(eval-when-compile (require 'esh-maint)) +;;; Code: + +(eval-when-compile (require 'eshell)) +(require 'esh-util) +(require 'esh-opt) (defgroup eshell-ls nil "This module implements the \"ls\" utility fully in Lisp. If it is @@ -35,14 +42,6 @@ properties to colorize its output based on the setting of :tag "Implementation of `ls' in Lisp" :group 'eshell-module) -;;; Commentary: - -;; Most of the command switches recognized by GNU's ls utility are -;; supported ([(fileutils)ls invocation]). - -(require 'esh-util) -(require 'esh-opt) - ;;; User Variables: (defvar eshell-ls-orig-insert-directory @@ -922,7 +921,7 @@ to use, and each member of which is the width of that column (car file))))) (car file)) -;;; Code: +(provide 'em-ls) ;;; arch-tag: 9295181c-0cb2-499c-999b-89f5359842cb ;;; em-ls.el ends here diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index a7f68e4e222..628b8b61143 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -22,18 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-pred) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-pred nil - "This module allows for predicates to be applied to globbing -patterns (similar to zsh), in addition to string modifiers which can -be applied either to globbing results, variable references, or just -ordinary strings." - :tag "Value modifiers and predicates" - :group 'eshell-module) - ;;; Commentary: ;; Argument predication is used to affect which members of a list are @@ -61,6 +49,16 @@ ordinary strings." ;;; Code: +(eval-when-compile (require 'eshell)) + +(defgroup eshell-pred nil + "This module allows for predicates to be applied to globbing +patterns (similar to zsh), in addition to string modifiers which can +be applied either to globbing results, variable references, or just +ordinary strings." + :tag "Value modifiers and predicates" + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-pred-load-hook '(eshell-pred-initialize) @@ -602,5 +600,7 @@ that 'ls -l' will show in the first column of its display. " (lambda (str) (split-string str ,sep))) lst)))) +(provide 'em-pred) + ;;; arch-tag: 8b5ce022-17f3-4c40-93c7-5faafaa63f31 ;;; em-pred.el ends here diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index ddbf74f5c42..57a1da74177 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -22,9 +22,14 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-prompt) +;;; Commentary: + +;; Most of the prompt navigation commands of `comint-mode' are +;; supported, such as C-c C-n, C-c C-p, etc. + +;;; Code: -(eval-when-compile (require 'esh-maint)) +(eval-when-compile (require 'eshell)) (defgroup eshell-prompt nil "This module provides command prompts, and navigation between them, @@ -32,11 +37,6 @@ as is common with most shells." :tag "Command prompts" :group 'eshell-module) -;;; Commentary: - -;; Most of the prompt navigation commands of `comint-mode' are -;; supported, such as C-c C-n, C-c C-p, etc. - ;;; User Variables: (defcustom eshell-prompt-load-hook '(eshell-prompt-initialize) @@ -173,7 +173,7 @@ If this takes us past the end of the current line, don't skip at all." (<= (match-end 0) eol)) (goto-char (match-end 0))))) -;;; Code: +(provide 'em-prompt) ;;; arch-tag: 01c1574b-ce70-4e89-bc38-e6619f61e208 ;;; em-prompt.el ends here diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 898f0b9d301..b550016fbe1 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -22,9 +22,11 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-rebind) +;;; Commentary: + +;;; Code: -(eval-when-compile (require 'esh-maint)) +(eval-when-compile (require 'eshell)) (defgroup eshell-rebind nil "This module allows for special keybindings that only take effect @@ -39,8 +41,6 @@ the behavior of normal shells while the user editing new input text." :tag "Rebind keys at input" :group 'eshell-module) -;;; Commentary: - ;;; User Variables: (defcustom eshell-rebind-load-hook '(eshell-rebind-initialize) @@ -242,7 +242,7 @@ input." (eshell-life-is-too-much))) (eshell-delete-backward-char (- arg))))) -;;; Code: +(provide 'em-rebind) ;;; arch-tag: 76d84f12-cc56-4d67-9b7d-c6b44ad20530 ;;; em-rebind.el ends here diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index 50fdc3ccccc..0a83881c03f 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -22,9 +22,9 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-script) +;;; Commentary: -(eval-when-compile (require 'esh-maint)) +;;; Code: (require 'eshell) @@ -34,8 +34,6 @@ commands, as a script file." :tag "Running script files." :group 'eshell-module) -;;; Commentary: - ;;; User Variables: (defcustom eshell-script-load-hook '(eshell-script-initialize) @@ -137,7 +135,7 @@ environment, binding ARGS to $1, $2, etc.") (put 'eshell/. 'eshell-no-numeric-conversions t) -;;; Code: +(provide 'em-script) ;;; arch-tag: a346439d-5ba8-4faf-ac2b-3aacfeaa4647 ;;; em-script.el ends here diff --git a/lisp/eshell/em-smart.el b/lisp/eshell/em-smart.el index f99a64bd17d..ffb1b4a4d92 100644 --- a/lisp/eshell/em-smart.el +++ b/lisp/eshell/em-smart.el @@ -22,21 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-smart) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-smart nil - "This module combines the facility of normal, modern shells with -some of the edit/review concepts inherent in the design of Plan 9's -9term. See the docs for more details. - -Most likely you will have to turn this option on and play around with -it to get a real sense of how it works." - :tag "Smart display of output" - ;; :link '(info-link "(eshell)Smart display of output") - :group 'eshell-module) - ;;; Commentary: ;; The best way to get a sense of what this code is trying to do is by @@ -84,6 +69,21 @@ it to get a real sense of how it works." ;; (such as pwd), where the screen is mostly full, consumption can ;; increase by orders of magnitude. +;;; Code: + +(eval-when-compile (require 'eshell)) + +(defgroup eshell-smart nil + "This module combines the facility of normal, modern shells with +some of the edit/review concepts inherent in the design of Plan 9's +9term. See the docs for more details. + +Most likely you will have to turn this option on and play around with +it to get a real sense of how it works." + :tag "Smart display of output" + ;; :link '(info-link "(eshell)Smart display of output") + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-smart-load-hook '(eshell-smart-initialize) @@ -322,7 +322,7 @@ and the end of the buffer are still visible." (if clear (remove-hook 'pre-command-hook 'eshell-smart-display-move t)))) -;;; Code: +(provide 'em-smart) ;;; arch-tag: 8c0112c7-379c-4d54-9a1c-204d68786a4b ;;; em-smart.el ends here diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el index 541773a4b5b..6ee698148da 100644 --- a/lisp/eshell/em-term.el +++ b/lisp/eshell/em-term.el @@ -22,19 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-term) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-term nil - "This module causes visual commands (e.g., 'vi') to be executed by -the `term' package, which comes with Emacs. This package handles most -of the ANSI control codes, allowing curses-based applications to run -within an Emacs window. The variable `eshell-visual-commands' defines -which commands are considered visual in nature." - :tag "Running visual commands" - :group 'eshell-module) - ;;; Commentary: ;; At the moment, eshell is stream-based in its interactive input and @@ -45,8 +32,20 @@ which commands are considered visual in nature." ;; buffer, giving the illusion that Eshell itself is allowing these ;; visual processes to execute. +;;; Code: + +(eval-when-compile (require 'eshell)) (require 'term) +(defgroup eshell-term nil + "This module causes visual commands (e.g., 'vi') to be executed by +the `term' package, which comes with Emacs. This package handles most +of the ANSI control codes, allowing curses-based applications to run +within an Emacs window. The variable `eshell-visual-commands' defines +which commands are considered visual in nature." + :tag "Running visual commands" + :group 'eshell-module) + ;;; User Variables: (defcustom eshell-term-load-hook '(eshell-term-initialize) @@ -264,7 +263,7 @@ allowed." ; "Switch to line (\"cooked\") sub-mode of eshell-term mode." ; (use-local-map term-old-mode-map)) -;;; Code: +(provide 'em-term) ;;; arch-tag: ab7c8fe4-3101-4257-925b-1354c6b2fe9d ;;; em-term.el ends here diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 33514d515af..e970c87f501 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -22,9 +22,22 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-unix) +;;; Commentary: + +;; This file contains implementations of several UNIX command in Emacs +;; Lisp, for several reasons: +;; +;; 1) it makes them available on all platforms where the Lisp +;; functions used are available +;; +;; 2) it makes their functionality accessible and modified by the +;; Lisp programmer. +;; +;; 3) it allows Eshell to refrain from having to invoke external +;; processes for common operations. + +;;; Code: -(eval-when-compile (require 'esh-maint)) (require 'eshell) (defgroup eshell-unix nil @@ -40,20 +53,6 @@ by name)." :tag "UNIX commands in Lisp" :group 'eshell-module) -;;; Commentary: - -;; This file contains implementations of several UNIX command in Emacs -;; Lisp, for several reasons: -;; -;; 1) it makes them available on all platforms where the Lisp -;; functions used are available -;; -;; 2) it makes their functionality accessible and modified by the -;; Lisp programmer. -;; -;; 3) it allows Eshell to refrain from having to invoke external -;; processes for common operations. - (defcustom eshell-unix-load-hook '(eshell-unix-initialize) "*A list of functions to run when `eshell-unix' is loaded." :type 'hook @@ -78,7 +77,7 @@ receiving side of a command pipeline." :type 'boolean :group 'eshell-unix) -(defcustom eshell-plain-locate-behavior (eshell-under-xemacs-p) +(defcustom eshell-plain-locate-behavior (featurep 'xemacs) "*If non-nil, standalone \"locate\" commands will behave normally. Standalone in this context means not redirected, and not on the receiving side of a command pipeline." @@ -137,8 +136,6 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." :type 'boolean :group 'eshell-unix) -(require 'esh-opt) - ;;; Functions: (defun eshell-unix-initialize () @@ -169,7 +166,7 @@ Otherwise, Emacs will attempt to use rsh to invoke du on the remote machine." (put 'eshell/man 'eshell-no-numeric-conversions t) (defun eshell/info (&rest args) - "Runs the info command in-frame with the same behaviour as command-line `info', ie: + "Run the info command in-frame with the same behavior as command-line `info', ie: 'info' => goes to top info window 'info arg1' => IF arg1 is a file, then visits arg1 'info arg1' => OTHERWISE goes to top info window and then menu item arg1 @@ -1050,7 +1047,7 @@ Show wall-clock time elapsed during execution of COMMAND.") (put 'eshell/occur 'eshell-no-numeric-conversions t) -;;; Code: +(provide 'em-unix) ;;; arch-tag: 2462edd2-a76a-4cf2-897d-92e9a82ac1c9 ;;; em-unix.el ends here diff --git a/lisp/eshell/em-xtra.el b/lisp/eshell/em-xtra.el index bd48afb6bd6..f0a92eb0c60 100644 --- a/lisp/eshell/em-xtra.el +++ b/lisp/eshell/em-xtra.el @@ -22,9 +22,14 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'em-xtra) +;;; Commentary: + +;;; Code: -(eval-when-compile (require 'esh-maint)) +(eval-when-compile + (require 'eshell) + (require 'pcomplete)) +(require 'compile) (defgroup eshell-xtra nil "This module defines some extra alias functions which are entirely @@ -34,10 +39,6 @@ naturally accessible within Emacs." :tag "Extra alias functions" :group 'eshell-module) -;;; Commentary: - -(require 'compile) - ;;; Functions: (defun eshell/expr (&rest args) @@ -117,7 +118,7 @@ naturally accessible within Emacs." (defalias 'pcomplete/bcc 'pcomplete/bcc32) -;;; Code: +(provide 'em-xtra) ;;; arch-tag: f944cfda-a118-470c-a0d6-b41a3a5c99c7 ;;; em-xtra.el ends here diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 011e2a55520..7db152d3604 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -22,9 +22,15 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. +;;; Commentary: + +;; Parsing of arguments can be extended by adding functions to the +;; hook `eshell-parse-argument-hook'. For a good example of this, see +;; `eshell-parse-drive-letter', defined in eshell-dirs.el. + (provide 'esh-arg) -(eval-when-compile (require 'esh-maint)) +(eval-when-compile (require 'eshell)) (defgroup eshell-arg nil "Argument parsing involves transforming the arguments passed on the @@ -33,12 +39,6 @@ yield the values intended." :tag "Argument parsing" :group 'eshell) -;;; Commentary: - -;; Parsing of arguments can be extended by adding functions to the -;; hook `eshell-parse-argument-hook'. For a good example of this, see -;; `eshell-parse-drive-letter', defined in eshell-dirs.el. - (defcustom eshell-parse-argument-hook (list ;; a term such as #<buffer NAME>, or #<process NAME> is a buffer diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index f999bdcdf6d..247d6c74604 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -22,18 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-cmd) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-cmd nil - "Executing an Eshell command is as simple as typing it in and -pressing <RET>. There are several different kinds of commands, -however." - :tag "Command invocation" - ;; :link '(info-link "(eshell)Command invocation") - :group 'eshell) - ;;; Commentary: ;;;_* Invoking external commands @@ -64,11 +52,6 @@ however." ;; functions always take precedence, set ;; `eshell-prefer-lisp-functions' to t. -(defcustom eshell-prefer-lisp-functions nil - "*If non-nil, prefer Lisp functions to external commands." - :type 'boolean - :group 'eshell-cmd) - ;;;_* Alias functions ;; ;; Whenever a command is specified using a simple name, such as 'ls', @@ -112,17 +95,44 @@ however." ;; ;; Lisp arguments are identified using the following regexp: +;;;_* Command hooks +;; +;; There are several hooks involved with command execution, which can +;; be used either to change or augment Eshell's behavior. + + +;;; Code: + +(require 'esh-util) +(unless (featurep 'xemacs) + (require 'eldoc)) +(require 'esh-arg) +(require 'esh-proc) +(require 'esh-ext) + +(eval-when-compile + (require 'pcomplete)) + + +(defgroup eshell-cmd nil + "Executing an Eshell command is as simple as typing it in and +pressing <RET>. There are several different kinds of commands, +however." + :tag "Command invocation" + ;; :link '(info-link "(eshell)Command invocation") + :group 'eshell) + +(defcustom eshell-prefer-lisp-functions nil + "*If non-nil, prefer Lisp functions to external commands." + :type 'boolean + :group 'eshell-cmd) + (defcustom eshell-lisp-regexp "\\([(`]\\|#'\\)" "*A regexp which, if matched at beginning of an argument, means Lisp. Such arguments will be passed to `read', and then evaluated." :type 'regexp :group 'eshell-cmd) -;;;_* Command hooks -;; -;; There are several hooks involved with command execution, which can -;; be used either to change or augment Eshell's behavior. - (defcustom eshell-pre-command-hook nil "*A hook run before each interactive command is invoked." :type 'hook @@ -219,15 +229,6 @@ return non-nil if the command is complex." (function :tag "Predicate"))) :group 'eshell-cmd) -;;; Code: - -(require 'esh-util) -(unless (eshell-under-xemacs-p) - (require 'eldoc)) -(require 'esh-arg) -(require 'esh-proc) -(require 'esh-ext) - ;;; User Variables: (defcustom eshell-cmd-load-hook '(eshell-cmd-initialize) @@ -394,6 +395,18 @@ hooks should be run before and after the command." (list 'eshell-commands commands) commands))) +(defun eshell-debug-command (tag subform) + "Output a debugging message to '*eshell last cmd*'." + (let ((buf (get-buffer-create "*eshell last cmd*")) + (text (eshell-stringify eshell-current-command))) + (save-excursion + (set-buffer buf) + (if (not tag) + (erase-buffer) + (insert "\n\C-l\n" tag "\n\n" text + (if subform + (concat "\n\n" (eshell-stringify subform)) "")))))) + (defun eshell-debug-show-parsed-args (terms) "Display parsed arguments in the debug buffer." (ignore @@ -956,18 +969,6 @@ at the moment are: "Completion for the `debug' command." (while (pcomplete-here '("errors" "commands")))) -(defun eshell-debug-command (tag subform) - "Output a debugging message to '*eshell last cmd*'." - (let ((buf (get-buffer-create "*eshell last cmd*")) - (text (eshell-stringify eshell-current-command))) - (save-excursion - (set-buffer buf) - (if (not tag) - (erase-buffer) - (insert "\n\C-l\n" tag "\n\n" text - (if subform - (concat "\n\n" (eshell-stringify subform)) "")))))) - (defun eshell-invoke-directly (command input) (let ((base (cadr (nth 2 (nth 2 (cadr command))))) name) (if (and (eq (car base) 'eshell-trap-errors) @@ -1418,5 +1419,7 @@ messages, and errors." (defalias 'eshell-lisp-command* 'eshell-lisp-command) +(provide 'esh-cmd) + ;;; arch-tag: 8e4f3867-a0c5-441f-96ba-ddd142d94366 ;;; esh-cmd.el ends here diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el index 11090f97b83..b3fc5c30bbe 100644 --- a/lisp/eshell/esh-ext.el +++ b/lisp/eshell/esh-ext.el @@ -22,17 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-ext) - -(eval-when-compile (require 'esh-maint)) -(require 'esh-util) - -(defgroup eshell-ext nil - "External commands are invoked when operating system executables are -loaded into memory, thus beginning a new process." - :tag "External commands" - :group 'eshell) - ;;; Commentary: ;; To force a command to invoked external, either provide an explicit @@ -43,6 +32,18 @@ loaded into memory, thus beginning a new process." ;; /bin/grep ; will definitely invoke /bin/grep ;; *grep ; will also invoke /bin/grep +(provide 'esh-ext) + +(eval-when-compile + (require 'esh-cmd)) +(require 'esh-util) + +(defgroup eshell-ext nil + "External commands are invoked when operating system executables are +loaded into memory, thus beginning a new process." + :tag "External commands" + :group 'eshell) + ;;; User Variables: (defcustom eshell-ext-load-hook '(eshell-ext-initialize) @@ -211,7 +212,7 @@ causing the user to wonder if anything's really going on..." (find-file-name-handler default-directory 'shell-command)))) (if (and handler - (not (and (eshell-under-xemacs-p) + (not (and (featurep 'xemacs) (eq handler 'dired-handler-fn)))) (eshell-remote-command handler command args)) (let ((interp (eshell-find-interpreter command))) diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index 897f9942d47..15a4af86346 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -22,17 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-io) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-io nil - "Eshell's I/O management code provides a scheme for treating many -different kinds of objects -- symbols, files, buffers, etc. -- as -though they were files." - :tag "I/O management" - :group 'eshell) - ;;; Commentary: ;; At the moment, only output redirection is supported in Eshell. To @@ -68,6 +57,17 @@ though they were files." ;; (+ 1 2) > a > b > c ; prints number to all three files ;; (+ 1 2) > a | wc ; prints to 'a', and pipes to 'wc' +(provide 'esh-io) + +(eval-when-compile (require 'eshell)) + +(defgroup eshell-io nil + "Eshell's I/O management code provides a scheme for treating many +different kinds of objects -- symbols, files, buffers, etc. -- as +though they were files." + :tag "I/O management" + :group 'eshell) + ;;; User Variables: (defcustom eshell-io-load-hook '(eshell-io-initialize) @@ -417,6 +417,10 @@ it defaults to `insert'." (defvar eshell-print-queue nil) (defvar eshell-print-queue-count -1) +(defsubst eshell-print (object) + "Output OBJECT to the standard output handle." + (eshell-output-object object eshell-output-handle)) + (defun eshell-flush (&optional reset-p) "Flush out any lines that have been queued for printing. Must be called before printing begins with -1 as its argument, and @@ -445,10 +449,6 @@ after all printing is over with no argument." (concat eshell-print-queue (apply 'concat strings)) eshell-print-queue-count (1+ eshell-print-queue-count)))) -(defsubst eshell-print (object) - "Output OBJECT to the standard output handle." - (eshell-output-object object eshell-output-handle)) - (defsubst eshell-error (object) "Output OBJECT to the standard error handle." (eshell-output-object object eshell-error-handle)) diff --git a/lisp/eshell/esh-maint.el b/lisp/eshell/esh-maint.el index 61a4ef9510d..3398014ff55 100644 --- a/lisp/eshell/esh-maint.el +++ b/lisp/eshell/esh-maint.el @@ -26,6 +26,8 @@ ;;; Code: +;; This cannot be moved to the end of the file without causing a +;; recursive require during bootstrap. (provide 'esh-maint) (and (fboundp 'font-lock-add-keywords) @@ -35,11 +37,7 @@ ("(eshell-deftest\\>" . font-lock-keyword-face) ("(eshell-condition-case\\>" . font-lock-keyword-face)))) -(if (file-directory-p "../pcomplete") - (add-to-list 'load-path "../pcomplete")) - -(if (locate-library "pcomplete") - (require 'pcomplete)) +(require 'pcomplete nil t) ; why? (eval-when-compile (require 'cl) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 8b7338f8833..eb618f6b6b8 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -22,15 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-mode) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-mode nil - "This module contains code for handling input from the user." - :tag "User interface" - :group 'eshell) - ;;; Commentary: ;; Basically, Eshell is used just like shell mode (<M-x shell>). The @@ -68,11 +59,19 @@ ;; ;; @ <C-c C-b> will move backward a complete shell argument. +(provide 'esh-mode) + +(eval-when-compile (require 'esh-util)) (require 'esh-module) (require 'esh-cmd) (require 'esh-io) (require 'esh-var) +(defgroup eshell-mode nil + "This module contains code for handling input from the user." + :tag "User interface" + :group 'eshell) + ;;; User Variables: (defcustom eshell-mode-unload-hook nil @@ -222,11 +221,6 @@ This is used by `eshell-watch-for-password-prompt'." (define-abbrev-table 'eshell-mode-abbrev-table ()) -(eval-when-compile - (unless (eshell-under-xemacs-p) - (defalias 'characterp 'ignore) - (defalias 'char-int 'ignore))) - (if (not eshell-mode-syntax-table) (let ((i 0)) (setq eshell-mode-syntax-table (make-syntax-table)) @@ -269,7 +263,7 @@ This is used by `eshell-watch-for-password-prompt'." (modify-syntax-entry ?\[ "(] " eshell-mode-syntax-table) (modify-syntax-entry ?\] ")[ " eshell-mode-syntax-table) ;; All non-word multibyte characters should be `symbol'. - (if (eshell-under-xemacs-p) + (if (featurep 'xemacs) (map-char-table (function (lambda (key val) @@ -470,7 +464,7 @@ This is used by `eshell-watch-for-password-prompt'." (eshell-deftest mode command-running-p "Modeline shows no command running" - (or (eshell-under-xemacs-p) + (or (featurep 'xemacs) (not eshell-status-in-modeline) (and (memq 'eshell-command-running-string mode-line-format) (equal eshell-command-running-string "--")))) diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el index 17067197909..cf9c2595a87 100644 --- a/lisp/eshell/esh-module.el +++ b/lisp/eshell/esh-module.el @@ -23,11 +23,15 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. +;;; Code: + (provide 'esh-module) (eval-when-compile - (require 'esh-maint) - (require 'cl)) + (require 'cl) + (require 'esh-util)) + +(require 'esh-util) (defgroup eshell-module nil "The `eshell-module' group is for Eshell extension modules, which @@ -36,10 +40,7 @@ customizing the variable `eshell-modules-list'." :tag "Extension modules" :group 'eshell) -;;; Commentary: - -(require 'esh-util) - +(eval-and-compile (defun eshell-load-defgroups (&optional directory) "Load `defgroup' statements from Eshell's module files." (let ((vc-handled-backends nil)) ; avoid VC fucking things up @@ -68,7 +69,9 @@ customizing the variable `eshell-modules-list'." (if defgroup (insert defgroup "\n\n"))) (setq files (cdr files)))) - (save-buffer)))) + ;; Don't make backups, to avoid prompting the user if there are + ;; excess backup versions. + (save-buffer 0))))) ;; load the defgroup's for the standard extension modules, so that ;; documentation can be provided when the user customize's diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index 66310895131..ec2279dff29 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -22,9 +22,11 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. +;;; Commentary: + (provide 'esh-opt) -(eval-when-compile (require 'esh-maint)) +(eval-when-compile (require 'esh-ext)) (defgroup eshell-opt nil "The options processing code handles command argument parsing for @@ -32,8 +34,6 @@ Eshell commands implemented in Lisp." :tag "Command options processing" :group 'eshell) -;;; Commentary: - ;;; User Functions: (defmacro eshell-eval-using-options (name macro-args diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index 7338756e3f8..c679ea7440a 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -22,9 +22,13 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. +;;; Commentary: + (provide 'esh-proc) -(eval-when-compile (require 'esh-maint)) +(eval-when-compile + (require 'eshell) + (require 'esh-util)) (defgroup eshell-proc nil "When Eshell invokes external commands, it always does so @@ -33,8 +37,6 @@ finish." :tag "Process management" :group 'eshell) -;;; Commentary: - ;;; User Variables: (defcustom eshell-proc-load-hook '(eshell-proc-initialize) diff --git a/lisp/eshell/esh-test.el b/lisp/eshell/esh-test.el index b4d65fa1f5e..a8e029b629c 100644 --- a/lisp/eshell/esh-test.el +++ b/lisp/eshell/esh-test.el @@ -22,15 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-test) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-test nil - "This module is meant to ensure that Eshell is working correctly." - :tag "Eshell test suite" - :group 'eshell) - ;;; Commentary: ;; The purpose of this module is to verify that Eshell works as @@ -39,8 +30,16 @@ ;;; Code: +(eval-when-compile + (require 'eshell) + (require 'esh-util)) (require 'esh-mode) +(defgroup eshell-test nil + "This module is meant to ensure that Eshell is working correctly." + :tag "Eshell test suite" + :group 'eshell) + ;;; User Variables: (defface eshell-test-ok @@ -236,5 +235,7 @@ "\n")))) nil t)) +(provide 'esh-test) + ;;; arch-tag: 6e32275a-8285-4a4e-b7cf-819aa7c86b8e ;;; esh-test.el ends here diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 25afdc38506..50243e76032 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -22,19 +22,15 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-util) +;;; Commentary: -(eval-when-compile (require 'esh-maint)) +;;; Code: (defgroup eshell-util nil "This is general utility code, meant for use by Eshell itself." :tag "General utilities" :group 'eshell) -;;; Commentary: - -(require 'pp) - ;;; User Variables: (defcustom eshell-stringify-t t @@ -139,10 +135,6 @@ function `string-to-number'." ;;; Functions: -(defsubst eshell-under-xemacs-p () - "Return non-nil if we are running under XEmacs." - (boundp 'xemacs-logo)) - (defsubst eshell-under-windows-p () "Return non-nil if we are running under MS-DOS/Windows." (memq system-type '(ms-dos windows-nt))) @@ -433,7 +425,9 @@ list." ;; "args out of range" error in `sit-for', if this function ;; runs while point is in the minibuffer and the users attempt ;; to use completion. Don't ask me. - (ignore-errors (sit-for 0 0))) + (condition-case nil + (sit-for 0 0) + (error nil))) (defun eshell-read-passwd-file (file) "Return an alist correlating gids to group names in FILE." @@ -636,7 +630,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. (autoload 'parse-time-string "parse-time")) (eval-when-compile - (load "ange-ftp" t)) + (require 'ange-ftp nil t)) (defun eshell-parse-ange-ls (dir) (let (entry) @@ -785,7 +779,7 @@ If NOSORT is non-nil, the list is not sorted--its order is unpredictable. ; (or result ; (file-attributes filename)))) -;;; Code: +(provide 'esh-util) ;;; arch-tag: 70159778-5c7a-480a-bae4-3ad332fca19d ;;; esh-util.el ends here diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 7c04b5a942a..dbc8802a9c5 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -22,18 +22,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'esh-var) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell-var nil - "Variable interpolation is introduced whenever the '$' character -appears unquoted in any argument (except when that argument is -surrounded by single quotes). It may be used to interpolate a -variable value, a subcommand, or even the result of a Lisp form." - :tag "Variable handling" - :group 'eshell) - ;;; Commentary: ;; These are the possible variable interpolation syntaxes. Also keep @@ -118,9 +106,25 @@ variable value, a subcommand, or even the result of a Lisp form." ;; contains the exit code of the last command (0 or 1 for Lisp ;; functions, based on successful completion). +(provide 'esh-var) + +(eval-when-compile + (require 'pcomplete) + (require 'esh-test) + (require 'esh-util) + (require 'esh-opt) + (require 'esh-mode)) (require 'env) (require 'ring) +(defgroup eshell-var nil + "Variable interpolation is introduced whenever the '$' character +appears unquoted in any argument (except when that argument is +surrounded by single quotes). It may be used to interpolate a +variable value, a subcommand, or even the result of a Lisp form." + :tag "Variable handling" + :group 'eshell) + ;;; User Variables: (defcustom eshell-var-load-hook '(eshell-var-initialize) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 23e36149174..58bc72a3ea9 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -24,21 +24,6 @@ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. -(provide 'eshell) - -(eval-when-compile (require 'esh-maint)) - -(defgroup eshell nil - "Eshell is a command shell implemented entirely in Emacs Lisp. It -invokes no external processes beyond those requested by the user. It -is intended to be a functional replacement for command shells such as -bash, zsh, rc, 4dos; since Emacs itself is capable of handling most of -the tasks accomplished by such tools." - :tag "The Emacs shell" - :link '(info-link "(eshell)Top") - :version "21.1" - :group 'applications) - ;;; Commentary: ;;;_* What does Eshell offer you? @@ -73,33 +58,9 @@ the tasks accomplished by such tools." ;; @ Alias functions, both Lisp and Eshell-syntax ;; @ Piping, sequenced commands, background jobs, etc... ;; -;;;_* Eshell is free software -;; -;; Eshell 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 3, 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. -;; -;; You should have received a copy of the GNU General Public License -;; along with Eshell; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, -;; MA 02110-1301, USA. -;; ;;;_* How to begin ;; -;; To start using Eshell, add the following to your .emacs file: -;; -;; (load "eshell-auto") -;; -;; This will define all of the necessary autoloads. -;; -;; Now type `M-x eshell'. See the INSTALL file for full installation -;; instructions. +;; To start using Eshell, simply type `M-x eshell'. ;; ;;;_* Philosophy ;; @@ -263,12 +224,28 @@ the tasks accomplished by such tools." ;; will only have to read in this one file, which will greatly speed ;; things up. +(eval-when-compile + (require 'cl) + (require 'esh-util)) +(require 'esh-util) +(require 'esh-mode) + +(defgroup eshell nil + "Eshell is a command shell implemented entirely in Emacs Lisp. It +invokes no external processes beyond those requested by the user. It +is intended to be a functional replacement for command shells such as +bash, zsh, rc, 4dos; since Emacs itself is capable of handling most of +the tasks accomplished by such tools." + :tag "The Emacs shell" + :link '(info-link "(eshell)Top") + :version "21.1" + :group 'applications) + + ;;;_* User Options ;; ;; The following user options modify the behavior of Eshell overall. - -(unless (featurep 'esh-util) - (load "esh-util" nil t)) +(defvar eshell-buffer-name) (defsubst eshell-add-to-window-buffer-names () "Add `eshell-buffer-name' to `same-window-buffer-names'." @@ -280,19 +257,19 @@ the tasks accomplished by such tools." (delete eshell-buffer-name same-window-buffer-names))) (defcustom eshell-load-hook nil - "*A hook run once Eshell has been loaded." + "A hook run once Eshell has been loaded." :type 'hook :group 'eshell) (defcustom eshell-unload-hook '(eshell-remove-from-window-buffer-names eshell-unload-all-modules) - "*A hook run when Eshell is unloaded from memory." + "A hook run when Eshell is unloaded from memory." :type 'hook :group 'eshell) (defcustom eshell-buffer-name "*eshell*" - "*The basename used for Eshell buffers." + "The basename used for Eshell buffers." :set (lambda (symbol value) ;; remove the old value of `eshell-buffer-name', if present (if (boundp 'eshell-buffer-name) @@ -309,7 +286,7 @@ the tasks accomplished by such tools." (member eshell-buffer-name same-window-buffer-names)) (defcustom eshell-directory-name (convert-standard-filename "~/.eshell/") - "*The directory where Eshell control files should be kept." + "The directory where Eshell control files should be kept." :type 'directory :group 'eshell) @@ -356,10 +333,8 @@ buffer selected (or created)." ;; `same-window-buffer-names', which is done when Eshell is loaded (assert (and buf (buffer-live-p buf))) (pop-to-buffer buf) - (if (fboundp 'eshell-mode) - (unless (eq major-mode 'eshell-mode) - (eshell-mode)) - (error "`eshell-auto' must be loaded before Eshell can be used")) + (unless (eq major-mode 'eshell-mode) + (eshell-mode)) buf)) (defun eshell-return-exits-minibuffer () @@ -406,7 +381,6 @@ With prefix ARG, insert output into the current buffer at point." (format " >>> #<buffer %s>" (buffer-name (current-buffer)))))) (save-excursion - (require 'esh-mode) (let ((buf (set-buffer (generate-new-buffer " *eshell cmd*"))) (eshell-non-interactive-p t)) (eshell-mode) @@ -465,7 +439,6 @@ corresponding to a successful execution." (if (and status-var (symbolp status-var)) (set status-var 0))) (with-temp-buffer - (require 'esh-mode) (let ((eshell-non-interactive-p t)) (eshell-mode) (let ((result (eshell-do-eval @@ -483,40 +456,12 @@ corresponding to a successful execution." ;;;_* Reporting bugs ;; -;; Since Eshell has not yet been in use by a wide audience, and since -;; the number of possible configurations is quite large, it is certain -;; that many bugs slipped past the rigors of testing it was put -;; through. If you do encounter a bug, on any system, please report +;; If you do encounter a bug, on any system, please report ;; it -- in addition to any particular oddities in your configuration ;; -- so that the problem may be corrected for the benefit of others. -(defconst eshell-report-bug-address "johnw@gnu.org" - "E-mail address to send Eshell bug reports to.") - ;;;###autoload -(defun eshell-report-bug (topic) - "Report a bug in Eshell. -Prompts for the TOPIC. Leaves you in a mail buffer. -Please include any configuration details that might be involved." - (interactive "sBug Subject: ") - (compose-mail eshell-report-bug-address topic) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) - (let ((signature (buffer-substring (point) (point-max)))) - ;; Discourage users from writing non-English text. - (set-buffer-multibyte nil) - (delete-region (point) (point-max)) - (insert signature) - (backward-char (length signature))) - (insert "emacs-version: " (emacs-version)) - (insert "\n\nThere appears to be a bug in Eshell.\n\n" - "Please describe exactly what actions " - "triggered the bug and the precise\n" - "symptoms of the bug:\n\n") - ;; This is so the user has to type something in order to send - ;; the report easily. - (use-local-map (nconc (make-sparse-keymap) (current-local-map)))) +(define-obsolete-function-alias 'eshell-report-bug 'report-emacs-bug "23.1") ;;; Code: @@ -543,5 +488,7 @@ Emacs." (run-hooks 'eshell-load-hook) +(provide 'eshell) + ;;; arch-tag: 9d4d5214-0e4e-4e02-b349-39add640d63f ;;; eshell.el ends here diff --git a/lisp/ffap.el b/lisp/ffap.el index 8c338bd947a..d045e5aa7f9 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -1045,6 +1045,9 @@ Assumes the buffer has not changed." ;; Older: (apply 'copy-region-as-kill ffap-string-at-point-region) (message "Copied to kill ring: %s" str)))) +;; External. +(declare-function w3-view-this-url "ext:w3" (&optional no-show)) + (defun ffap-url-at-point nil "Return url from around point if it exists, or nil." ;; Could use w3's url-get-url-at-point instead. Both handle "URL:", @@ -1687,20 +1690,8 @@ Only intended for interactive use." ;;; Bug Reporter: -(defun ffap-bug nil - "Submit a bug report for the ffap package." - ;; Important: keep the version string here in synch with that at top - ;; of file! Could use lisp-mnt from Emacs 19, but that would depend - ;; on being able to find the ffap.el source file. - (interactive) - (require 'reporter) - (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report - "Michelangelo Grigni <mic@mathcs.emory.edu>" - "ffap" - (mapcar 'intern (all-completions "ffap-" obarray 'boundp))))) - -(fset 'ffap-submit-bug 'ffap-bug) ; another likely name +(define-obsolete-function-alias 'ffap-bug 'report-emacs-bug "23.1") +(define-obsolete-function-alias 'ffap-submit-bug 'report-emacs-bug "23.1") ;;; Hooks for Gnus, VM, Rmail: @@ -1724,6 +1715,13 @@ Only intended for interactive use." (defvar gnus-summary-buffer) (defvar gnus-article-buffer) +;; This code is called from gnus. +(declare-function gnus-summary-select-article "gnus-sum" + (&optional all-headers force pseudo article)) + +(declare-function gnus-configure-windows "gnus-win" + (setting &optional force)) + (defun ffap-gnus-wrapper (form) ; used by both commands below (and (eq (current-buffer) (get-buffer gnus-summary-buffer)) (gnus-summary-select-article)) ; get article of current line diff --git a/lisp/filecache.el b/lisp/filecache.el index 18c537fed7c..5138c947b7d 100644 --- a/lisp/filecache.el +++ b/lisp/filecache.el @@ -780,10 +780,6 @@ match REGEXP." ;; Keybindings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;###autoload (define-key minibuffer-local-completion-map [C-tab] 'file-cache-minibuffer-complete) -;;;###autoload (define-key minibuffer-local-map [C-tab] 'file-cache-minibuffer-complete) -;;;###autoload (define-key minibuffer-local-must-match-map [C-tab] 'file-cache-minibuffer-complete) - (provide 'filecache) ;;; arch-tag: 433d3ca4-4af2-47ce-b2cf-1f727460f538 diff --git a/lisp/files.el b/lisp/files.el index a7dd79b8a88..8d5fcfda8c2 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -213,6 +213,15 @@ have fast storage with limited space, such as a RAM disk." ;; The system null device. (Should reference NULL_DEVICE from C.) (defvar null-device "/dev/null" "The system null device.") +(declare-function msdos-long-file-names "msdos.c") +(declare-function w32-long-file-name "w32proc.c") +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(declare-function dired-unmark "dired" (arg)) +(declare-function dired-do-flagged-delete "dired" (&optional nomessage)) +(declare-function dos-8+3-filename "dos-fns" (filename)) +(declare-function vms-read-directory "vms-patch" (dirname switches buffer)) +(declare-function view-mode-disable "view" ()) + (defvar file-name-invalid-regexp (cond ((and (eq system-type 'ms-dos) (not (msdos-long-file-names))) (concat "^\\([^A-Z[-`a-z]\\|..+\\)?:\\|" ; colon except after drive @@ -2428,7 +2437,11 @@ Otherwise, return nil; point may be changed." ;; put them in the first line of ;; such a file without screwing up ;; the interpreter invocation. - (and (looking-at "^#!") 2)) t) + ;; The same holds for + ;; '\" + ;; in man pages (preprocessor + ;; magic for the `man' program). + (and (looking-at "^\\(#!\\|'\\\\\"\\)") 2)) t) (progn (skip-chars-forward " \t") (setq beg (point)) @@ -2619,7 +2632,7 @@ n -- to ignore the local variables list.") (if offer-save '(?! ?y ?n ?\s ?\C-g) '(?y ?n ?\s ?\C-g))) done) (while (not done) - (message prompt) + (message "%s" prompt) (setq char (read-event)) (if (numberp char) (cond ((eq char ?\C-v) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index f8201250096..dab7c9b3af4 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -886,6 +886,13 @@ The value of this variable is used when Font Lock mode is turned on." (defvar lazy-lock-mode) (defvar jit-lock-mode) +(declare-function fast-lock-after-fontify-buffer "fast-lock") +(declare-function fast-lock-after-unfontify-buffer "fast-lock") +(declare-function fast-lock-mode "fast-lock") +(declare-function lazy-lock-after-fontify-buffer "lazy-lock") +(declare-function lazy-lock-after-unfontify-buffer "lazy-lock") +(declare-function lazy-lock-mode "lazy-lock") + (defun font-lock-turn-on-thing-lock () (let ((thing-mode (font-lock-value-in-major-mode font-lock-support-mode))) (cond ((eq thing-mode 'fast-lock-mode) diff --git a/lisp/gnus/format-spec.el b/lisp/format-spec.el index 951f9aecb81..951f9aecb81 100644 --- a/lisp/gnus/format-spec.el +++ b/lisp/format-spec.el diff --git a/lisp/frame.el b/lisp/frame.el index 1c11829475b..df3ed16f574 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -292,8 +292,9 @@ there (in decreasing order of priority)." ;; the buffer of the selected window, which fails when the selected ;; window is the minibuffer. (let ((old-buffer (current-buffer)) - (window-system-frame-alist (cdr (assq initial-window-system - window-system-default-frame-alist)))) + (window-system-frame-alist + (cdr (assq initial-window-system + window-system-default-frame-alist)))) (when (and frame-notice-user-settings (null frame-initial-frame)) @@ -599,6 +600,8 @@ is not considered (see `next-frame')." 0)) (select-frame-set-input-focus (selected-frame))) +(declare-function x-initialize-window-system "term/x-win" ()) + (defun make-frame-on-display (display &optional parameters) "Make a frame on X display DISPLAY. The optional second argument PARAMETERS specifies additional frame parameters." @@ -714,7 +717,8 @@ setup is for focus to follow the pointer." (let ((type (terminal-live-p (cdr (assq 'terminal parameters))))) (cond ((eq type t) nil) - ((eq type nil) (error "Terminal %s does not exist" (cdr (assq 'terminal parameters)))) + ((eq type nil) (error "Terminal %s does not exist" + (cdr (assq 'terminal parameters)))) (t type)))) ((assq 'window-system parameters) (cdr (assq 'window-system parameters))) @@ -725,7 +729,10 @@ setup is for focus to follow the pointer." (unless frame-creation-function (error "Don't know how to create a frame on window system %s" w)) (run-hooks 'before-make-frame-hook) - (setq frame (funcall frame-creation-function (append parameters (cdr (assq w window-system-default-frame-alist))))) + (setq frame + (funcall frame-creation-function + (append parameters + (cdr (assq w window-system-default-frame-alist))))) (normal-erase-is-backspace-setup-frame frame) ;; Inherit the original frame's parameters. (dolist (param frame-inherited-parameters) @@ -1126,6 +1133,8 @@ bars (top, bottom, or nil)." "Return the terminal that is now selected." (frame-terminal (selected-frame))) +(declare-function msdos-mouse-p "dosfns.c") + (defun display-mouse-p (&optional display) "Return non-nil if DISPLAY has a mouse available. DISPLAY can be a display name, a frame, or nil (meaning the selected diff --git a/lisp/generic-x.el b/lisp/generic-x.el index fbabf6e6996..f400b299b9e 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -383,6 +383,10 @@ your changes into effect." "Generic mode for HOSTS files.")) ;;; Windows INF files + +;; If i-g-m-f-f-h is defined, then so is i-g-m. +(declare-function ini-generic-mode "generic-x") + (when (memq 'inf-generic-mode generic-extras-enable-list) (define-generic-mode inf-generic-mode @@ -443,6 +447,8 @@ like an INI file. You can add this hook to `find-file-hook'." '((nil "^\\s-*\\(.*\\)\\s-*=" 1)))))) "Generic mode for MS-Windows Registry files.")) +(declare-function w32-shell-name "w32-fns" ()) + ;;; DOS/Windows BAT files (when (memq 'bat-generic-mode generic-extras-enable-list) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 7ac757f24e2..bb92d478277 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,422 @@ +2007-12-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-use-idna) + * gnus-start.el (gnus-site-init-file) + * message.el (message-use-idna) + * mm-uu.el (mm-uu-hide-markers) + * smiley.el (smiley-style): Revert changes that suppress warnings. + +2007-12-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-article-browse-html-parts): Add meta html tag to + specify charset to html source. Reported by Christoph Conrad + <christoph.conrad@gmx.de>. + +2007-12-05 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (gnus-use-idna): Don't directly refer to the value of + idna-program in order to suppress byte compile warning issued by XEmacs + that came to byte compile the default value section of defcustom forms + recently. + + * gnus-start.el (gnus-site-init-file): Don't directly refer to the + value of installation-directory. + + * message.el (message-use-idna): Don't directly refer to the value of + idna-program. + + * mm-uu.el (mm-uu-hide-markers): Don't directly call defined-colors. + + * smiley.el (smiley-style): Don't directly call face-attribute. + +2007-12-04 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-group.el (gnus-group-highlight-line): Add FIXME. + + * gnus-dired.el: Reduce Gnus dependencies. + (gnus-ems, gnus-msg, gnus-util, message, mm-decode, mml): Don't + require. Use autoloads instead. + (mml-attach-file, mm-default-file-encoding, mailcap-extension-to-mime) + (mailcap-mime-info, mm-mailcap-command, ps-print-preprint) + (message-buffers, gnus-setup-message, gnus-print-buffer): Autoload. + (gnus-dired-mode): Adjust doc string. + (gnus-dired-mail-mode): New variable. + (gnus-dired-mode-map): Avoid using `gnus-define-keys'. + (gnus-dired-mode): Avoid using `gnus-run-hooks'. + (gnus-dired-mail-buffers): New function. Return mail or message + composition buffers. + (gnus-dired-attach): Use it. + (gnus-dired-find-file-mailcap): Call `mailcap-mime-info' with + NO-DECODE. + (gnus-dired-print): Use `gnus-print-buffer' depending on + `gnus-dired-mail-mode'. + +2007-12-04 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-encoded-word-regexp) + (rfc2047-encoded-word-regexp-loose): Move forward; add comments + explaining what regexp patterns are for. + +2007-12-04 Glenn Morris <rgm@gnu.org> + + * password.el: Move to ../password-cache.el. + + * mml1991.el (password-read, password-cache-add, password-cache-remove): + * mml2015.el (password-read, password-cache-add, password-cache-remove): + * mml-smime.el (password-read, password-cache-add) + (password-cache-remove): + No need to autoload, since mml-sec requires password. + + * gnus.el (gnus-spam-resend-to, gnus-ham-resend-to): + * message.el (gnus-extract-address-components): + * mml-smime.el (gnus-extract-address-components): Define for compiler. + + * mml-sec.el, sieve-manage.el, smime.el: Require password-cache or + password. + +2007-12-03 Reiner Steib <Reiner.Steib@gmx.de> + + * mailcap.el: Reduce dependencies. + (mail-header-parse-content-type): Autoload. + (mailcap-delete-duplicates): New alias. + (mailcap-mime-info): Add optional argument NO-DECODE. + (mailcap-mime-types): Use mailcap-delete-duplicates. + + * message.el (message-ignored-supersedes-headers): Add "X-ID". + +2007-12-03 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-sum.el (gnus-uu-extract-map): Add a command for the yenc + function. + + * gnus-uu.el (gnus-uu-decode-yenc): New command. + (gnus-uu-yenc-article): New function. + + * yenc.el (yenc-first-part-p, yenc-last-part-p): New functions. + + * mm-uu.el (mm-uu-yenc-extract): Get the data from the original + buffer. + +2007-12-02 Glenn Morris <rgm@gnu.org> + + * sasl-cram.el, sasl-digest.el, sasl-ntlm.el, sasl.el: + Move to ../net. + + * binhex.el, uudecode.el: Move to ../mail. + + * encrypt.el: Remove file. + +2007-12-01 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-cite-prefix-regexp): Remove `-' and `+' to avoid + matches on patches. + + * gnus-art.el (gnus-article-browse-html-article): Mention + `mm-text-html-renderer' in the doc string. + + * rfc2047.el (rfc2047-encode-max-chars): Refer to RFC 2047 in doc + string. Add comments. + + * message.el (message-idna-to-ascii-rhs-1): Don't call `idna-to-ascii' + if rhs is ASCII. + +2007-12-01 Glenn Morris <rgm@gnu.org> + + * dig.el, dns.el: Move to ../net. + * format-spec.el, hex-util.el, sha1.el: Move to ../. + + * mail-source.el (top-level): Require format-spec before + eval-when-compile. + +2007-11-30 Glenn Morris <rgm@gnu.org> + + * encrypt.el: Require password, rather than autoloading password-read. + +2007-11-28 Elias Oltmanns <eo@nebensachen.de> + + * gnus.el (gnus-method-to-server): Add an optional parameter so the + caller can indicate whether the cache should be disregarded for this + call. This way the result of the call is reproducible at all times and + can be considered a canonical server name for the supplied method. + (gnus-agent-method-p): Canonicalize server names by pushing their + method through `gnus-method-to-server' using the no-cache argument. + + * gnus-srvr.el (gnus-server-insert-server-line): Call + `gnus-method-to-server' with `no-cache' argument. + + * gnus-agent.el (gnus-agent-toggle-plugged): Don't call + gnus-agent-possibly-synchronize-flags as this should be called when the + server is actually being opened. + (gnus-agent-possibly-synchronize-flags) + (gnus-agent-possibly-synchronize-flags-server): Move check for the + flags file of an agentized server to the latter function. + + * gnus-int.el (gnus-agent-possibly-synchronize-flags-server): Autoload. + (gnus-open-server): Call gnus-agent-possibly-synchronize-flags-server + after a connection has been established successfully. + +2007-11-28 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-art.el (article-display-face): Force to display face if called + interactively; check if gnus-article-x-face-too-ugly matches author. + (article-display-x-face): Display face even if From header is missing + as article-display-face does. + +2007-11-28 Richard Stallman <rms@gnu.org> + + * md4.el: Move to ../. + * hmac-def.el, hmac-md5.el, ntlm.el: Move to ../net. + +2007-11-27 Reiner Steib <Reiner.Steib@gmx.de> + + * mail-source.el (mail-sources): Default to fetch from file for + compatibility with default of nnmail-spool-file. + +2007-11-27 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2047.el (rfc2047-allow-irregular-q-encoded-words): New variable. + (rfc2047-encodable-p): Use rfc2047-encoded-word-regexp instead of "=?" + to look for encoded word that should be encoded again. + (rfc2047-encoded-word-regexp): Make B encoding pattern strict. + (rfc2047-encoded-word-regexp-loose): New constant that has loose Q + encoding pattern. + (rfc2047-decode-region): Switch strict regexp and loose one according + to rfc2047-allow-irregular-q-encoded-words. + +2007-11-26 Simon Josefsson <simon@josefsson.org> + + * imap.el: Move to ../net directory. + +2007-11-25 Romain Francoise <romain@orebokech.com> + + * gnus-msg.el (gnus-summary-reply): Delete extra paren. + +2007-11-24 Reiner Steib <Reiner.Steib@gmx.de> + + * nnmail.el (nnmail-spool-file): Remove obsolete variable. + (nnmail-get-new-mail): Remove code using `nnmail-spool-file'. + + * gnus-start.el (defvar, gnus-get-unread-articles): Remove code using + `nnmail-spool-file'. + + * nnkiboze.el (nnkiboze-generate-groups): Don't bind obsolete + `nnmail-spool-file'. + + * gnus-move.el (gnus-change-server): Ditto. + + * gnus-kill.el (gnus-batch-score): Ditto. + + * gnus-cache.el (gnus-jog-cache): Ditto. + + * gnus-msg.el (gnus-summary-reply): Ignore + gnus-confirm-mail-reply-to-news for wide and very wide replies. + +2007-11-24 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-cache.el (gnus-cache-generate-nov-databases): Use + nnml-generate-nov-databases-directory instead of + nnml-generate-nov-databases-1. + +2007-11-24 Glenn Morris <rgm@gnu.org> + + * message.el (message-tool-bar-retro): Update for rename + mail_send.xpm->mail-send.xpm. + +2007-11-22 Reiner Steib <Reiner.Steib@gmx.de> + + * smime.el (smime-cert-by-ldap-1): Use `ldap-search' instead of + `smime-ldap-search' for Emacs 22 and up. + +2007-11-22 Reiner Steib <Reiner.Steib@gmx.de> + + * hashcash.el: Move to ../mail directory. + + * smime-ldap.el: Remove. Not used in Emacs 22 and up. + + * smime.el (smime-cert-by-ldap-1): Use `ldap-search' instead of + `smime-ldap-search' for Emacs 22 and up. + +2007-11-22 Stefan Monnier <monnier@iro.umontreal.ca> + + * gnus-art.el (gnus-article-truncate-lines): Use `truncate-lines'. + + * message.el (message-send-mail-function): Fix error convention. + (message-mailer-swallows-blank-line, message-send-mail-with-sendmail) + (message-widen-reply, message-send-mail, message-talkative-question) + (message-with-reply-buffer, message-generate-new-buffer-clone-locals) + (message-clone-locals, message-send-news): Use with-current-buffer. + (message-insert-or-toggle-importance): Remove unused var `valid'. + (message-make-references): Remove unused var `new-references'. + (message-make-mail-followup-to): Remove unused var `subscribed-lists'. + +2007-11-22 Juanma Barranquero <lekktu@gmail.com> + + * spam.el (spam-find-spam, spam-enter-list): Doc fixes. + (spam-split-symbolic-return-positive): Reflow docstring. + (spam-backends, spam-summary-exit-behavior) + (spam-mark-ham-unread-before-move-from-spam-group) + (spam-summary-score-preferred-header, spam-sa-learn-spam-switch) + (spam-sa-learn-ham-switch, spam-sa-learn-unregister-switch) + (spam-clear-cache, spam-backend-check, spam-install-backend) + (spam-install-statistical-backend, spam-list-of-processors) + (spam-group-processor-p, spam-split, spam-bogofilter-score) + (spam-bsfilter-score, spam-check-bsfilter, spam-crm114-score) + (spam-check-crm114, spam-initialize, spam-unload-hook): + Fix typos in docstrings. + +2007-11-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-get-unread-articles): Mark groups as having never + been checked if they have never been read and those group levels are + higher than the one that a user specified. + +2007-11-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-get-unread-articles): Don't prevent from checking + foreign groups unless a group level is specified by a user. + Reported by Dan Nicolaescu <dann@ics.uci.edu>. + +2007-11-21 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-send-mail-function): Require sendmail. + +2007-11-20 Reiner Steib <Reiner.Steib@gmx.de> + + * message.el (message-send-mail-function): Check for smtpmail too. + + * utf7.el (utf7-encode, utf7-decode): Use coding system + `utf-7'/`utf-7-imap' from utf-7.el' if available. + + * message.el (message-send-mail-function): New function. + (message-send-mail-function): Set default using + message-send-mail-function. Adjust doc string. + (message-send-mail-with-mailclient): New function. + +2007-11-17 Richard Stallman <rms@gnu.org> + + * assistant.el: Remove file. + +2007-11-16 Dan Nicolaescu <dann@ics.uci.edu> + + * smime.el (from): + * rfc2047.el (message-posting-charset): + * qp.el (mm-use-ultra-safe-encoding): + * pop3.el (parse-time-months): + * nnrss.el (mm-text-html-renderer, mm-text-html-washer-alist): + * nnml.el (files): + * nnheader.el (gnus-newsgroup-name, nnheader-file-coding-system) + (jka-compr-compression-info-list, ange-ftp-path-format) + (efs-path-regexp): + * nndiary.el (files): + * mml2015.el (mc-default-scheme, mc-schemes, pgg-default-user-id) + (pgg-errors-buffer, pgg-output-buffer, epg-user-id-alist) + (epg-digest-algorithm-alist, inhibit-redisplay) + (password-cache-expiry): + * mml1991.el (pgg-default-user-id, pgg-errors-buffer) + (pgg-output-buffer, password-cache-expiry): + * mml.el (mml-dnd-protocol-alist, ange-ftp-name-format) + (efs-path-regexp): + * mml-smime.el (epg-user-id-alist, epg-digest-algorithm-alist) + (inhibit-redisplay): + * mm-uu.el (file-name, start-point, end-point, entry) + (gnus-newsgroup-name, gnus-newsgroup-charset): + * mm-util.el (mm-mime-mule-charset-alist, latin-unity-coding-systems) + (latin-unity-ucs-list): + * mm-bodies.el (mm-uu-yenc-decode-function, mm-uu-decode-function) + (mm-uu-binhex-decode-function): + * message.el (gnus-message-group-art, gnus-list-identifiers, ) + (rmail-enable-mime-composing, gnus-local-organization) + (gnus-post-method, gnus-select-method, gnus-active-hashtb) + (gnus-read-active-file, facemenu-add-face-function) + (facemenu-remove-face-function, gnus-article-decoded-p) + (tool-bar-mode): + * mail-source.el (display-time-mail-function): + * gnus-util.el (nnmail-pathname-coding-system) + (nnmail-active-file-coding-system, gnus-emphasize-whitespace-regexp) + (gnus-original-article-buffer, gnus-user-agent) + (rmail-default-rmail-file, mm-text-coding-system, tool-bar-mode) + (xemacs-codename, sxemacs-codename, emacs-program-version): + * gnus-sum.el (tool-bar-mode, gnus-tmp-header, number): + * gnus-start.el (gnus-agent-covered-methods) + (gnus-agent-file-loading-local, gnus-agent-file-loading-cache) + (gnus-current-headers, gnus-thread-indent-array, gnus-newsgroup-name) + (gnus-newsgroup-headers, gnus-group-list-mode) + (gnus-group-mark-positions, gnus-newsgroup-data) + (gnus-newsgroup-unreads, nnoo-state-alist) + (gnus-current-select-method, mail-sources) + (nnmail-scan-directory-mail-source-once, nnmail-split-history) + (nnmail-spool-file, gnus-cache-active-hashtb): + * gnus-mh.el (mh-lib-progs): + * gnus-ems.el (gnus-tmp-unread, gnus-tmp-replied) + (gnus-tmp-score-char, gnus-tmp-indentation, gnus-tmp-opening-bracket) + (gnus-tmp-lines, gnus-tmp-name, gnus-tmp-closing-bracket) + (gnus-tmp-subject-or-nil, gnus-check-before-posting, gnus-mouse-face) + (gnus-group-buffer): + * gnus-cite.el (font-lock-defaults-computed, font-lock-keywords) + (font-lock-set-defaults): + * gnus-art.el (tool-bar-map, w3m-minor-mode-map) + (gnus-face-properties-alist, charset, gnus-summary-article-menu) + (gnus-summary-post-menu, total-parts, type, condition, length): + * gnus-agent.el (gnus-agent-read-agentview): + * flow-fill.el (show-trailing-whitespace): + * gnus-group.el (tool-bar-mode, nnrss-group-alist): Remove unnecessary + eval-and-compile wrappers for byte compiler pacifiers. + + * mm-view.el (mm-inline-image-xemacs): Only do something for XEmacs. + (mm-display-inline-fontify): Check for featurep 'xemacs not + extent-list. + + * mm-decode.el (mm-display-external): Check for featurep 'xemacs not + itimer-list. + (mm-create-image-xemacs): Only do something for XEmacs. + (mm-image-fit-p): Check for featurep 'xemacs not glyph-width. + + * mm-util.el (mm-find-buffer-file-coding-system): Add check for XEmacs. + + * gnus-registry.el (gnus-adaptive-word-syntax-table): + * gnus-fun.el (gnus-face-properties-alist): Pacify byte compiler. + +2007-11-15 Juanma Barranquero <lekktu@gmail.com> + + * nnimap.el (nnimap-split-download-body): + * gnus-demon.el (gnus-demon): + * gnus-uu.el (gnus-uu-default-view-rules): Fix typos in docstrings. + +2007-11-15 Katsumi Yamaoka <yamaoka@jpl.org> + + * nntp.el (nntp-insert-buffer-substring, nntp-copy-to-buffer): New + macros. + (nntp-wait-for, nntp-retrieve-articles, nntp-async-trigger) + (nntp-retrieve-headers-with-xover): Use nntp-insert-buffer-substring to + copy data from unibyte buffer to multibyte current buffer. + (nntp-retrieve-headers, nntp-retrieve-groups); Use nntp-copy-to-buffer + to copy data from unibyte current buffer to multibyte buffer. + (nntp-make-process-buffer): Make process buffer unibyte. + + * pop3.el (pop3-open-server): Fix typo in Lisp code. + +2007-11-14 Denys Duchier <denys.duchier@univ-orleans.fr> (tiny change) + + * pop3.el (pop3-open-server): Accept and process data more robustly at + connexion start to avoid spurious "POP SSL connexion failed" errors. + +2007-11-14 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-start.el (gnus-active-to-gnus-format): Use unibyte buffer to + read group names. + +2007-11-12 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-msg.el (gnus-confirm-mail-reply-to-news): Adjust :version. + +2007-11-12 Katsumi Yamaoka <yamaoka@jpl.org> + + * nnmail.el (nnmail-parse-active): Make group names unibyte. + (nnmail-save-active): Use a unibyte buffer when saving active file, + which may contain non-ASCII group names. + + * nnml.el (nnml-request-group): Decode group names in messages. + 2007-11-05 Reiner Steib <Reiner.Steib@gmx.de> * message.el (message-citation-line-function) @@ -265,7 +684,7 @@ 2007-10-04 Reiner Steib <Reiner.Steib@gmx.de> - * Relicense "GPLv2 or later" files to "GPLv3 or later". + * Relicense "GPLv2 or later" files to "GPLv3 or later". 2007-09-27 Teodor Zlatanov <tzz@lifelogs.com> @@ -10350,7 +10769,7 @@ eval-when-compile, to define gnus-agent-set-cat-groups as the setf method of gnus-agent-cat-groups even when the buffer has been evaled. - (gnus-agent-save-active,gnus-agent-save-active-1): Merged to + (gnus-agent-save-active, gnus-agent-save-active-1): Merged to delete gnus-agent-save-active-1. (gnus-agent-save-groups): Deleted. Identical to gnus-agent-save-active. @@ -10361,12 +10780,12 @@ servers. Add use of min/max range limits from server's local file. (gnus-agent-save-alist): Removed unused optional argument. - (gnus-agent-load-local,gnus-agent-read-and-cache-local), - (gnus-agent-read-local,gnus-agent-save-local,gnus-agent-get-local), + (gnus-agent-load-local, gnus-agent-read-and-cache-local), + (gnus-agent-read-local, gnus-agent-save-local, gnus-agent-get-local), (gnus-agent-set-local): A per-server file that keeps min/max range - limits for articles known to the agent. Provides a fast mechanism + limits for articles known to the agent. Provides a fast mechanism for altering many active ranges. - (gnus-agent-expire-group,gnus-agent-expire): No longer save the + (gnus-agent-expire-group, gnus-agent-expire): No longer save the active file (local makes it unnecessary). (gnus-agent-regenerate-group): Fixed XEmacs compatibility. diff --git a/lisp/gnus/assistant.el b/lisp/gnus/assistant.el deleted file mode 100644 index 25ff1732f8f..00000000000 --- a/lisp/gnus/assistant.el +++ /dev/null @@ -1,487 +0,0 @@ -;;; assistant.el --- guiding users through Emacs setup -;; Copyright (C) 2004, 2005 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> -;; Keywords: util - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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 3, or (at your option) -;; any later version. - -;; GNU Emacs 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. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(require 'widget) -(require 'wid-edit) - -(autoload 'gnus-error "gnus-util") -(autoload 'netrc-get "netrc") -(autoload 'netrc-machine "netrc") -(autoload 'netrc-parse "netrc") - -(defvar assistant-readers - '(("variable" assistant-variable-reader) - ("validate" assistant-sexp-reader) - ("result" assistant-list-reader) - ("next" assistant-list-reader) - ("text" assistant-text-reader))) - -(defface assistant-field '((t (:bold t))) - "Face used for editable fields." - :group 'gnus-article-emphasis) -;; backward-compatibility alias -(put 'assistant-field-face 'face-alias 'assistant-field) - -;;; Internal variables - -(defvar assistant-data nil) -(defvar assistant-current-node nil) -(defvar assistant-previous-nodes nil) -(defvar assistant-widgets nil) - -(defun assistant-parse-buffer () - (let (results command value) - (goto-char (point-min)) - (while (search-forward "@" nil t) - (if (not (looking-at "[^ \t\n]+")) - (error "Dangling @") - (setq command (downcase (match-string 0))) - (goto-char (match-end 0))) - (setq value - (if (looking-at "[ \t]*\n") - (let (start) - (forward-line 1) - (setq start (point)) - (unless (re-search-forward (concat "^@end " command) nil t) - (error "No @end %s found" command)) - (beginning-of-line) - (prog1 - (buffer-substring start (point)) - (forward-line 1))) - (skip-chars-forward " \t") - (prog1 - (buffer-substring (point) (point-at-eol)) - (forward-line 1)))) - (push (list command (assistant-reader command value)) - results)) - (assistant-segment (nreverse results)))) - -(defun assistant-text-reader (text) - (with-temp-buffer - (insert text) - (goto-char (point-min)) - (let ((start (point)) - (sections nil)) - (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t) - (push (buffer-substring start (match-beginning 0)) - sections) - (push (list (match-string 1) (match-string 2)) - sections) - (setq start (point))) - (push (buffer-substring start (point-max)) - sections) - (nreverse sections)))) - -;; Segment the raw assistant data into a list of nodes. -(defun assistant-segment (list) - (let ((ast nil) - (node nil) - (title (pop list))) - (dolist (elem list) - (when (and (equal (car elem) "node") - node) - (push (list "save" nil) node) - (push (nreverse node) ast) - (setq node nil)) - (push elem node)) - (when node - (push (list "save" nil) node) - (push (nreverse node) ast)) - (cons title (nreverse ast)))) - -(defun assistant-reader (command value) - (let ((formatter (cadr (assoc command assistant-readers)))) - (if (not formatter) - value - (funcall formatter value)))) - -(defun assistant-list-reader (value) - (car (read-from-string (concat "(" value ")")))) - -(defun assistant-variable-reader (value) - (let ((section (car (read-from-string (concat "(" value ")"))))) - (append section (list 'default)))) - -(defun assistant-sexp-reader (value) - (if (zerop (length value)) - nil - (car (read-from-string value)))) - -(defun assistant-buffer-name (title) - (format "*Assistant %s*" title)) - -(defun assistant-get (ast command) - (cadr (assoc command ast))) - -(defun assistant-set (ast command value) - (let ((elem (assoc command ast))) - (when elem - (setcar (cdr elem) value)))) - -(defun assistant-get-list (ast command) - (let ((result nil)) - (dolist (elem ast) - (when (equal (car elem) command) - (push elem result))) - (nreverse result))) - -;;;###autoload -(defun assistant (file) - "Assist setting up Emacs based on FILE." - (interactive "fAssistant file name: ") - (let ((ast - (with-temp-buffer - (insert-file-contents file) - (assistant-parse-buffer)))) - (pop-to-buffer (assistant-buffer-name (assistant-get ast "title"))) - (assistant-render ast))) - -(defun assistant-render (ast) - (let ((first-node (assistant-get (nth 1 ast) "node"))) - (set (make-local-variable 'assistant-data) ast) - (set (make-local-variable 'assistant-current-node) nil) - (set (make-local-variable 'assistant-previous-nodes) nil) - (assistant-render-node first-node))) - -(defun assistant-find-node (node-name) - (let ((ast (cdr assistant-data))) - (while (and ast - (not (string= node-name (assistant-get (car ast) "node")))) - (pop ast)) - (car ast))) - -(defun assistant-node-name (node) - (assistant-get node "node")) - -(defun assistant-previous-node-text (node) - (format "<< Go back to %s" node)) - -(defun assistant-next-node-text (node) - (if (and node - (not (eq node 'finish))) - (format "Proceed to %s >>" node) - "Finish")) - -(defun assistant-set-defaults (node &optional forcep) - (dolist (variable (assistant-get-list node "variable")) - (setq variable (cadr variable)) - (when (or (eq (nth 3 variable) 'default) - forcep) - (setcar (nthcdr 3 variable) - (assistant-eval (nth 2 variable)))))) - -(defun assistant-get-variable (node variable &optional type raw) - (let ((variables (assistant-get-list node "variable")) - (result nil) - elem) - (while (and (setq elem (pop variables)) - (not result)) - (setq elem (cadr elem)) - (when (eq (intern variable) (car elem)) - (if type - (setq result (nth 1 elem)) - (setq result (if raw (nth 3 elem) - (format "%s" (nth 3 elem))))))) - result)) - -(defun assistant-set-variable (node variable value) - (let ((variables (assistant-get-list node "variable")) - elem) - (while (setq elem (pop variables)) - (setq elem (cadr elem)) - (when (eq (intern variable) (car elem)) - (setcar (nthcdr 3 elem) value))))) - -(defun assistant-render-text (text node) - (unless (and text node) - (gnus-error - 5 - "The assistant was asked to render invalid text or node data")) - (dolist (elem text) - (if (stringp elem) - ;; Ordinary text - (insert elem) - ;; A variable to be inserted as a widget. - (let* ((start (point)) - (variable (cadr elem)) - (type (assistant-get-variable node variable 'type))) - (cond - ((eq (car-safe type) :radio) - (push - (apply - #'widget-create - 'radio-button-choice - :assistant-variable variable - :assistant-node node - :value (assistant-get-variable node variable) - :notify (lambda (widget &rest ignore) - (assistant-set-variable - (widget-get widget :assistant-node) - (widget-get widget :assistant-variable) - (widget-value widget)) - (assistant-render-node - (assistant-get - (widget-get widget :assistant-node) - "node"))) - (cadr type)) - assistant-widgets)) - ((eq (car-safe type) :set) - (push - (apply - #'widget-create - 'set - :assistant-variable variable - :assistant-node node - :value (assistant-get-variable node variable nil t) - :notify (lambda (widget &rest ignore) - (assistant-set-variable - (widget-get widget :assistant-node) - (widget-get widget :assistant-variable) - (widget-value widget)) - (assistant-render-node - (assistant-get - (widget-get widget :assistant-node) - "node"))) - (cadr type)) - assistant-widgets)) - (t - (push - (widget-create - 'editable-field - :value-face 'assistant-field - :assistant-variable variable - (assistant-get-variable node variable)) - assistant-widgets) - ;; The editable-field widget apparently inserts a newline; - ;; remove it. - (delete-char -1) - (add-text-properties start (point) - (list - 'bold t - 'face 'assistant-field - 'not-read-only t)))))))) - -(defun assistant-render-node (node-name) - (let ((node (assistant-find-node node-name)) - (inhibit-read-only t) - (previous assistant-current-node) - (buffer-read-only nil)) - (unless node - (gnus-error 5 "The node for %s could not be found" node-name)) - (set (make-local-variable 'assistant-widgets) nil) - (assistant-set-defaults node) - (if (equal (assistant-get node "type") "interstitial") - (assistant-render-node (nth 0 (assistant-find-next-nodes node-name))) - (setq assistant-current-node node-name) - (when previous - (push previous assistant-previous-nodes)) - (erase-buffer) - (insert (cadar assistant-data) "\n\n") - (insert node-name "\n\n") - (assistant-render-text (assistant-get node "text") node) - (insert "\n\n") - (when assistant-previous-nodes - (assistant-node-button 'previous (car assistant-previous-nodes))) - (widget-create - 'push-button - :assistant-node node-name - :notify (lambda (widget &rest ignore) - (let* ((node (widget-get widget :assistant-node))) - (assistant-set-defaults (assistant-find-node node) 'force) - (assistant-render-node node))) - "Reset") - (insert "\n") - (dolist (nnode (assistant-find-next-nodes)) - (assistant-node-button 'next nnode) - (insert "\n")) - - (goto-char (point-min)) - (assistant-make-read-only)))) - -(defun assistant-make-read-only () - (let ((start (point-min)) - end) - (while (setq end (text-property-any start (point-max) 'not-read-only t)) - (put-text-property start end 'read-only t) - (put-text-property start end 'rear-nonsticky t) - (while (get-text-property end 'not-read-only) - (incf end)) - (setq start end)) - (put-text-property start (point-max) 'read-only t))) - -(defun assistant-node-button (type node) - (let ((text (if (eq type 'next) - (assistant-next-node-text node) - (assistant-previous-node-text node)))) - (widget-create - 'push-button - :assistant-node node - :assistant-type type - :notify (lambda (widget &rest ignore) - (let* ((node (widget-get widget :assistant-node)) - (type (widget-get widget :assistant-type))) - (if (eq type 'previous) - (progn - (setq assistant-current-node nil) - (pop assistant-previous-nodes)) - (assistant-get-widget-values) - (assistant-validate)) - (if (null node) - (assistant-finish) - (assistant-render-node node)))) - text) - (use-local-map widget-keymap))) - -(defun assistant-validate-types (node) - (dolist (variable (assistant-get-list node "variable")) - (setq variable (cadr variable)) - (let ((type (nth 1 variable)) - (value (nth 3 variable))) - (when - (cond - ((eq type :number) - (string-match "[^0-9]" value)) - (t - nil)) - (error "%s is not of type %s: %s" - (car variable) type value))))) - -(defun assistant-get-widget-values () - (let ((node (assistant-find-node assistant-current-node))) - (dolist (widget assistant-widgets) - (assistant-set-variable - node (widget-get widget :assistant-variable) - (widget-value widget))))) - -(defun assistant-validate () - (let* ((node (assistant-find-node assistant-current-node)) - (validation (assistant-get node "validate")) - result) - (assistant-validate-types node) - (when validation - (when (setq result (assistant-eval validation)) - (unless (y-or-n-p (format "Error: %s. Continue? " result)) - (error "%s" result)))) - (assistant-set node "save" t))) - -;; (defun assistant-find-next-node (&optional node) -;; (let* ((node (assistant-find-node (or node assistant-current-node))) -;; (node-name (assistant-node-name node)) -;; (nexts (assistant-get-list node "next")) -;; next elem applicable) - -;; (while (setq elem (pop nexts)) -;; (when (assistant-eval (car (cadr elem))) -;; (setq applicable (cons elem applicable)))) - -;; ;; return the first thing we can -;; (cadr (cadr (pop applicable))))) - -(defun assistant-find-next-nodes (&optional node) - (let* ((node (assistant-find-node (or node assistant-current-node))) - (nexts (assistant-get-list node "next")) - next elem applicable return) - - (while (setq elem (pop nexts)) - (when (assistant-eval (car (cadr elem))) - (setq applicable (cons elem applicable)))) - - ;; return the first thing we can - - (while (setq elem (pop applicable)) - (push (cadr (cadr elem)) return)) - - return)) - -(defun assistant-get-all-variables () - (let ((variables nil)) - (dolist (node (cdr assistant-data)) - (setq variables - (append (assistant-get-list node "variable") - variables))) - variables)) - -(defun assistant-eval (form) - (let ((bindings nil)) - (dolist (variable (assistant-get-all-variables)) - (setq variable (cadr variable)) - (push (list (car variable) - (if (eq (nth 3 variable) 'default) - nil - (if (listp (nth 3 variable)) - `(list ,@(nth 3 variable)) - (nth 3 variable)))) - bindings)) - (eval - `(let ,bindings - ,form)))) - -(defun assistant-finish () - (let ((results nil) - result) - (dolist (node (cdr assistant-data)) - (when (assistant-get node "save") - (setq result (assistant-get node "result")) - (push (list (car result) - (assistant-eval (cadr result))) - results))) - (message "Results: %s" - (nreverse results)))) - -;;; Validation functions. - -(defun assistant-validate-connect-to-server (server port) - (let* ((error nil) - (stream - (condition-case err - (open-network-stream "nntpd" nil server port) - (error (setq error err))))) - (if (and (processp stream) - (memq (process-status stream) '(open run))) - (progn - (delete-process stream) - nil) - error))) - -(defun assistant-authinfo-data (server port type) - (when (file-exists-p "~/.authinfo") - (netrc-get (netrc-machine (netrc-parse "~/.authinfo") - server port) - (if (eq type 'user) - "login" - "password")))) - -(defun assistant-password-required-p () - nil) - -(provide 'assistant) - -;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b -;;; assistant.el ends here diff --git a/lisp/gnus/canlock.el b/lisp/gnus/canlock.el index fed5598104d..145a2e518d2 100644 --- a/lisp/gnus/canlock.el +++ b/lisp/gnus/canlock.el @@ -6,18 +6,20 @@ ;; Author: Katsumi Yamaoka <yamaoka@jpl.org> ;; Keywords: news, cancel-lock, hmac, sha1, rfc2104 -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) ;; any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/gnus/ecomplete.el b/lisp/gnus/ecomplete.el index 1c333fd2e03..42a75916277 100644 --- a/lisp/gnus/ecomplete.el +++ b/lisp/gnus/ecomplete.el @@ -1,5 +1,6 @@ ;;; ecomplete.el --- electric completion of addresses and the like -;; Copyright (C) 2006 Free Software Foundation, Inc. + +;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: mail diff --git a/lisp/gnus/encrypt.el b/lisp/gnus/encrypt.el deleted file mode 100644 index 1fb54a280eb..00000000000 --- a/lisp/gnus/encrypt.el +++ /dev/null @@ -1,296 +0,0 @@ -;;; encrypt.el --- file encryption routines -;; Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Created: 2003/01/24 -;; Keywords: files - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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 3, or (at your option) -;; any later version. - -;; GNU Emacs 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. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;;; This module addresses data encryption. Page breaks are used for -;;; grouping declarations and documentation relating to each -;;; particular aspect. - -;;; Use in Gnus like this: -;;; (setq -;;; nnimap-authinfo-file "~/.authinfo.enc" -;;; nntp-authinfo-file "~/.authinfo.enc" -;;; smtpmail-auth-credentials "~/.authinfo.enc" -;;; ;; using the AES256 cipher, feel free to use your own favorite -;;; encrypt-file-alist (quote (("~/.authinfo.enc" (gpg "AES256")))) -;;; password-cache-expiry 600) - -;;; Then write ~/.authinfo.enc: - -;;; 1) open the old authinfo -;;; C-x C-f ~/.authinfo - -;;; 2) write the new authinfo.enc -;;; M-x encrypt-write-file-contents RET ~/.authinfo.enc - -;;; 3) verify the new authinfo is correct (this will show the contents in the minibuffer) -;;; M-: (encrypt-get-file-contents "~/.authinfo.enc") - - -;;; Code: - -;; autoload password -(eval-and-compile - (autoload 'password-read "password")) - -(defgroup encrypt '((password-cache custom-variable) - (password-cache-expiry custom-variable)) - "File encryption configuration." - :group 'applications) - -(defcustom encrypt-file-alist nil - "List of file names or regexes matched with encryptions. -Format example: - '((\"beta\" - (gpg \"AES\")) - (\"/home/tzz/alpha\" - (encrypt-xor \"Semi-Secret\")))" - - :type '(repeat - (list :tag "Encryption entry" - (radio :tag "What to encrypt" - (file :tag "Filename") - (regexp :tag "Regular expression match")) - (radio :tag "How to encrypt it" - (list - :tag "GPG Encryption" - (const :tag "GPG Program" gpg) - (radio :tag "Choose a cipher" - (const :tag "3DES Encryption" "3DES") - (const :tag "CAST5 Encryption" "CAST5") - (const :tag "Blowfish Encryption" "BLOWFISH") - (const :tag "AES Encryption" "AES") - (const :tag "AES192 Encryption" "AES192") - (const :tag "AES256 Encryption" "AES256") - (const :tag "Twofish Encryption" "TWOFISH") - (string :tag "Cipher Name"))) - (list - :tag "Built-in simple XOR" - (const :tag "XOR Encryption" encrypt-xor) - (string :tag "XOR Cipher Value (seed value)"))))) - :group 'encrypt) - -;; TODO: now, load gencrypt.el and if successful, modify the -;; custom-type of encrypt-file-alist to add the gencrypt.el options - -;; (plist-get (symbol-plist 'encrypt-file-alist) 'custom-type) -;; then use plist-put - -(defcustom encrypt-gpg-path (executable-find "gpg") - "Path to the GPG program." - :type '(radio - (file :tag "Location of the GPG executable") - (const :tag "GPG is not installed" nil)) - :group 'encrypt) - -(defvar encrypt-temp-prefix "encrypt" - "Prefix for temporary filenames") - -;;;###autoload -(defun encrypt-find-model (filename) - "Given a filename, find a encrypt-file-alist entry" - (dolist (entry encrypt-file-alist) - (let ((match (nth 0 entry)) - (model (nth 1 entry))) - (when (or (eq match filename) - (string-match match filename)) - (return model))))) - -;;;###autoload -(defun encrypt-insert-file-contents (file &optional model) - "Decrypt FILE into the current buffer." - (interactive "fFile to insert: ") - (let* ((model (or model (encrypt-find-model file))) - (method (nth 0 model)) - (cipher (nth 1 model)) - (password-key (format "encrypt-password-%s-%s %s" - (symbol-name method) cipher file)) - (passphrase - (password-read-and-add - (format "%s password for cipher %s (file %s)? " - file (symbol-name method) cipher) - password-key)) - (buffer-file-coding-system 'binary) - (coding-system-for-read 'binary) - outdata) - - ;; note we only insert-file-contents if the method is known to be valid - (cond - ((eq method 'gpg) - (insert-file-contents file) - (setq outdata (encrypt-gpg-decode-buffer passphrase cipher))) - ((eq method 'encrypt-xor) - (insert-file-contents file) - (setq outdata (encrypt-xor-decode-buffer passphrase cipher)))) - - (if outdata - (progn - (message "%s was decrypted with %s (cipher %s)" - file (symbol-name method) cipher) - (delete-region (point-min) (point-max)) - (goto-char (point-min)) - (insert outdata)) - ;; the decryption failed, alas - (password-cache-remove password-key) - (gnus-error 5 "%s was NOT decrypted with %s (cipher %s)" - file (symbol-name method) cipher)))) - -(defun encrypt-get-file-contents (file &optional model) - "Decrypt FILE and return the contents." - (interactive "fFile to decrypt: ") - (with-temp-buffer - (encrypt-insert-file-contents file model) - (buffer-string))) - -(defun encrypt-put-file-contents (file data &optional model) - "Encrypt the DATA to FILE, then continue normally." - (with-temp-buffer - (insert data) - (encrypt-write-file-contents file model))) - -(defun encrypt-write-file-contents (file &optional model) - "Encrypt the current buffer to FILE, then continue normally." - (interactive "sFile to write: ") - (setq model (or model (encrypt-find-model file))) - (if model - (let* ((method (nth 0 model)) - (cipher (nth 1 model)) - (password-key (format "encrypt-password-%s-%s %s" - (symbol-name method) cipher file)) - (passphrase - (password-read - (format "%s password for cipher %s? " - (symbol-name method) cipher) - password-key)) - outdata) - - (cond - ((eq method 'gpg) - (setq outdata (encrypt-gpg-encode-buffer passphrase cipher))) - ((eq method 'encrypt-xor) - (setq outdata (encrypt-xor-encode-buffer passphrase cipher)))) - - (if outdata - (progn - (message "%s was encrypted with %s (cipher %s)" - file (symbol-name method) cipher) - (delete-region (point-min) (point-max)) - (goto-char (point-min)) - (insert outdata) - ;; do not confirm overwrites - (write-file file nil)) - ;; the decryption failed, alas - (password-cache-remove password-key) - (gnus-error 5 "%s was NOT encrypted with %s (cipher %s)" - file (symbol-name method) cipher))) - (gnus-error 1 "%s has no associated encryption model! See encrypt-file-alist." file))) - -(defun encrypt-xor-encode-buffer (passphrase cipher) - (encrypt-xor-process-buffer passphrase cipher t)) - -(defun encrypt-xor-decode-buffer (passphrase cipher) - (encrypt-xor-process-buffer passphrase cipher nil)) - -(defun encrypt-xor-process-buffer (passphrase - cipher - &optional encode) - "Given PASSPHRASE, xor-encode or decode the contents of the current buffer." - (let* ((bs (buffer-substring-no-properties (point-min) (point-max))) - ;; passphrase-sum is a simple additive checksum of the - ;; passphrase and the cipher - (passphrase-sum - (when (stringp passphrase) - (apply '+ (append cipher passphrase nil)))) - new-list) - - (with-temp-buffer - (if encode - (progn - (dolist (x (append bs nil)) - (setq new-list (cons (logxor x passphrase-sum) new-list))) - - (dolist (x new-list) - (insert (format "%d " x)))) - (progn - (setq new-list (reverse (split-string bs))) - (dolist (x new-list) - (setq x (string-to-number x)) - (insert (format "%c" (logxor x passphrase-sum)))))) - (buffer-substring-no-properties (point-min) (point-max))))) - -(defun encrypt-gpg-encode-buffer (passphrase cipher) - (encrypt-gpg-process-buffer passphrase cipher t)) - -(defun encrypt-gpg-decode-buffer (passphrase cipher) - (encrypt-gpg-process-buffer passphrase cipher nil)) - -(defun encrypt-gpg-process-buffer (passphrase - cipher - &optional encode) - "With PASSPHRASE, use GPG to encode or decode the current buffer." - (let* ((program encrypt-gpg-path) - (input (buffer-substring-no-properties (point-min) (point-max))) - (temp-maker (if (fboundp 'make-temp-file) - 'make-temp-file - 'make-temp-name)) - (temp-file (funcall temp-maker encrypt-temp-prefix)) - (default-enable-multibyte-characters nil) - (args `("--cipher-algo" ,cipher - "--status-fd" "2" - "--logger-fd" "2" - "--passphrase-fd" "0" - "--no-tty")) - exit-status exit-data) - - (when encode - (setq args - (append args - '("--symmetric" - "--armor")))) - - (if program - (with-temp-buffer - (when passphrase - (insert passphrase "\n")) - (insert input) - (setq exit-status - (apply #'call-process-region (point-min) (point-max) program - t `(t ,temp-file) nil args)) - (if (equal exit-status 0) - (setq exit-data - (buffer-substring-no-properties (point-min) (point-max))) - (with-temp-buffer - (when (file-exists-p temp-file) - (insert-file-contents temp-file)) - (gnus-error 5 (format "%s exited abnormally: '%s' [%s]" - program exit-status (buffer-string))))) - (delete-file temp-file)) - (gnus-error 5 "GPG is not installed.")) - exit-data)) - -(provide 'encrypt) -;;; encrypt.el ends here - -;; arch-tag: d907e4f1-71b5-42b1-a180-fc7b84ff0648 diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el index 1644ed0f8f2..a13cd23156d 100644 --- a/lisp/gnus/flow-fill.el +++ b/lisp/gnus/flow-fill.el @@ -154,8 +154,7 @@ RFC 2646 suggests 66 characters for readability." ;; Test vectors. -(eval-when-compile - (defvar show-trailing-whitespace)) +(defvar show-trailing-whitespace) (defvar fill-flowed-encode-tests `( diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 0271186273a..22ffd585973 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -636,8 +636,7 @@ manipulated as follows: (gnus-agent-make-mode-line-string " Plugged" 'mouse-2 'gnus-agent-toggle-plugged)) - (gnus-agent-go-online gnus-agent-go-online) - (gnus-agent-possibly-synchronize-flags)) + (gnus-agent-go-online gnus-agent-go-online)) (t (gnus-agent-close-connections) (setq gnus-plugged set-to) @@ -868,8 +867,7 @@ be a select method." (interactive) (save-excursion (dolist (gnus-command-method (gnus-agent-covered-methods)) - (when (and (file-exists-p (gnus-agent-lib-file "flags")) - (eq (gnus-server-status gnus-command-method) 'ok)) + (when (eq (gnus-server-status gnus-command-method) 'ok) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-synchronize-flags-server (method) @@ -905,11 +903,13 @@ be a select method." (defun gnus-agent-possibly-synchronize-flags-server (method) "Synchronize flags for server according to `gnus-agent-synchronize-flags'." - (when (or (and gnus-agent-synchronize-flags - (not (eq gnus-agent-synchronize-flags 'ask))) - (and (eq gnus-agent-synchronize-flags 'ask) - (gnus-y-or-n-p (format "Synchronize flags on server `%s'? " - (cadr method))))) + (when (and (file-exists-p (gnus-agent-lib-file "flags")) + (or (and gnus-agent-synchronize-flags + (not (eq gnus-agent-synchronize-flags 'ask))) + (and (eq gnus-agent-synchronize-flags 'ask) + (gnus-y-or-n-p + (format "Synchronize flags on server `%s'? " + (cadr method)))))) (gnus-agent-synchronize-flags-server method))) ;;;###autoload @@ -2104,8 +2104,7 @@ doesn't exist, to valid the overview buffer." ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. -(eval-when-compile - (defvar gnus-agent-read-agentview)) +(defvar gnus-agent-read-agentview) (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 0c98babcad5..4bb9ceb97ba 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -28,9 +28,9 @@ ;;; Code: (eval-when-compile - (require 'cl) - (defvar tool-bar-map) - (defvar w3m-minor-mode-map)) + (require 'cl)) +(defvar tool-bar-map) +(defvar w3m-minor-mode-map) (require 'gnus) ;; Avoid the "Recursive load suspected" error in Emacs 21.1. @@ -2222,7 +2222,7 @@ unfolded." (mail-header-fold-field) (goto-char (point-max)))))) -(defcustom gnus-article-truncate-lines default-truncate-lines +(defcustom gnus-article-truncate-lines (default-value 'truncate-lines) "Value of `truncate-lines' in Gnus Article buffer. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." @@ -2332,12 +2332,11 @@ long lines iff arg is positive." (forward-line 1) (point)))))) -(eval-when-compile - (defvar gnus-face-properties-alist)) +(defvar gnus-face-properties-alist) -(defun article-display-face () +(defun article-display-face (&optional force) "Display any Face headers in the header." - (interactive) + (interactive (list 'force)) (let ((wash-face-p buffer-read-only)) (gnus-with-article-headers ;; When displaying parts, this function can be called several times on @@ -2347,7 +2346,8 @@ long lines iff arg is positive." ;; read-only. (if (and wash-face-p (memq 'face gnus-article-wash-types)) (gnus-delete-images 'face) - (let (face faces from) + (let ((from (message-fetch-field "from")) + face faces) (save-current-buffer (when (and wash-face-p (gnus-buffer-live-p gnus-original-article-buffer) @@ -2355,16 +2355,22 @@ long lines iff arg is positive." (set-buffer gnus-original-article-buffer)) (save-restriction (mail-narrow-to-head) - (while (gnus-article-goto-header "Face") - (push (mail-header-field-value) faces)))) + (when (or force + ;; Check whether this face is censored. + (not (and gnus-article-x-face-too-ugly + (or from + (setq from (message-fetch-field "from"))) + (string-match gnus-article-x-face-too-ugly + from)))) + (while (gnus-article-goto-header "Face") + (push (mail-header-field-value) faces))))) (when faces (goto-char (point-min)) - (let ((from (gnus-article-goto-header "from")) - png image) - (unless from + (let (png image) + (unless (setq from (gnus-article-goto-header "from")) (insert "From:") (setq from (point)) - (insert "[no `from' set]\n")) + (insert " [no `from' set]\n")) (while faces (when (setq png (gnus-convert-face-to-png (pop faces))) (setq image @@ -2389,7 +2395,8 @@ long lines iff arg is positive." ;; instead. (gnus-delete-images 'xface) ;; Display X-Faces. - (let (x-faces from face) + (let ((from (message-fetch-field "from")) + x-faces face) (save-current-buffer (when (and wash-face-p (gnus-buffer-live-p gnus-original-article-buffer) @@ -2400,43 +2407,41 @@ long lines iff arg is positive." (set-buffer gnus-original-article-buffer)) (save-restriction (mail-narrow-to-head) - (while (gnus-article-goto-header "X-Face") - (push (mail-header-field-value) x-faces)) - (setq from (message-fetch-field "from")))) - ;; Sending multiple EOFs to xv doesn't work, so we only do a - ;; single external face. - (when (stringp gnus-article-x-face-command) - (setq x-faces (list (car x-faces)))) - (when (and x-faces - gnus-article-x-face-command - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and from - (not (string-match gnus-article-x-face-too-ugly - from))))) - (while (setq face (pop x-faces)) - ;; We display the face. - (cond ((stringp gnus-article-x-face-command) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (gnus-set-process-query-on-exit-flag - (start-process - "article-x-face" nil shell-file-name - shell-command-switch gnus-article-x-face-command) - nil) - (with-temp-buffer - (insert face) - (process-send-region "article-x-face" - (point-min) (point-max))) - (process-send-eof "article-x-face"))) - ((functionp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (funcall gnus-article-x-face-command face)) - (t - (error "%s is not a function" - gnus-article-x-face-command)))))))))) + (and gnus-article-x-face-command + (or force + ;; Check whether this face is censored. + (not (and gnus-article-x-face-too-ugly + (or from + (setq from (message-fetch-field "from"))) + (string-match gnus-article-x-face-too-ugly + from)))) + (while (gnus-article-goto-header "X-Face") + (push (mail-header-field-value) x-faces))))) + (when x-faces + ;; We display the face. + (cond ((functionp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (mapc gnus-article-x-face-command x-faces)) + ((stringp gnus-article-x-face-command) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (gnus-set-process-query-on-exit-flag + (start-process + "article-x-face" nil shell-file-name + shell-command-switch gnus-article-x-face-command) + nil) + ;; Sending multiple EOFs to xv doesn't work, + ;; so we only do a single external face. + (with-temp-buffer + (insert (car x-faces)) + (process-send-region "article-x-face" + (point-min) (point-max))) + (process-send-eof "article-x-face"))) + (t + (error "`%s' set to `%s' is not a function" + gnus-article-x-face-command + 'gnus-article-x-face-command))))))))) (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." @@ -2726,7 +2731,7 @@ charset defined in `gnus-summary-show-article-charset-alist' is used." ;; Put the mark meaning this part was rendered by emacs-w3m. 'mm-inline-text-html-with-w3m t)))) -(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'. +(defvar charset) ;; Bound by `article-wash-html'. (defun gnus-article-wash-html-with-w3m-standalone () "Wash the current buffer with w3m." @@ -2797,8 +2802,37 @@ Recurse into multiparts." (string-match "text/html" (car (mm-handle-type handle)))) (let ((tmp-file (mm-make-temp-file ;; Do we need to care for 8.3 filenames? - "mm-" nil ".html"))) - (mm-save-part-to-file handle tmp-file) + "mm-" nil ".html")) + (charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (if charset + ;; Add a meta html tag to specify charset. + (mm-with-unibyte-buffer + (insert (with-current-buffer (mm-handle-buffer handle) + (if (eq charset 'gnus-decoded) + (mm-encode-coding-string + (buffer-string) + (setq charset 'utf-8)) + (buffer-string)))) + (setq charset (format "\ +<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" + charset)) + (goto-char (point-min)) + (let ((case-fold-search t)) + (cond (;; Don't modify existing meta tag. + (re-search-forward "\ +<meta[\t\n\r ]+http-equiv=\"content-type\"[^>]+>" + nil t)) + ((re-search-forward "<head>[\t\n\r ]*" nil t) + (insert charset "\n")) + (t + (re-search-forward "\ +<html\\(?:[\t\n\r ]+[^>]+\\|[\t\n\r ]*\\)>[\t\n\r ]*" + nil t) + (insert "<head>\n" charset "\n</head>\n")))) + (mm-write-region (point-min) (point-max) + tmp-file nil nil nil 'binary t)) + (mm-save-part-to-file handle tmp-file)) (add-to-list 'gnus-article-browse-html-temp-list tmp-file) (add-hook 'gnus-summary-prepare-exit-hook 'gnus-article-browse-delete-temp-files) @@ -2824,7 +2858,10 @@ Warning: Spammers use links to images in HTML articles to verify whether you have read the message. As `gnus-article-browse-html-article' passes the unmodified HTML content to the browser without eliminating these \"web bugs\" you -should only use it for mails from trusted senders." +should only use it for mails from trusted senders. + +If you alwasy want to display HTML part in the browser, set +`mm-text-html-renderer' to nil." ;; Cf. `mm-w3m-safe-url-regexp' (interactive) (save-window-excursion @@ -3529,9 +3566,8 @@ This format is defined by the `gnus-article-time-format' variable." gnus-newsgroup-name 'highlight-words t))) gnus-emphasis-alist))))) -(eval-when-compile - (defvar gnus-summary-article-menu) - (defvar gnus-summary-post-menu)) +(defvar gnus-summary-article-menu) +(defvar gnus-summary-post-menu) ;;; Saving functions. @@ -7903,12 +7939,11 @@ For example: (funcall (cadr elem))))))) ;; Dynamic variables. -(eval-when-compile - (defvar part-number) - (defvar total-parts) - (defvar type) - (defvar condition) - (defvar length)) +(defvar part-number) +(defvar total-parts) +(defvar type) +(defvar condition) +(defvar length) (defun gnus-treat-predicate (val) (cond diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 1e76e3ac57b..6341c8e48d8 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -1,6 +1,6 @@ ;;; gnus-bookmark.el --- Bookmarks in Gnus -;; Copyright (C) 2006 Free Software Foundation, Inc. +;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;; Author: Bastien Guerry <bzg AT altern DOT org> ;; Keywords: news diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index fecb0685858..4f61a0f2759 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -92,7 +92,7 @@ it's not cached." (defvar gnus-cache-total-fetched-hashtb nil) (eval-and-compile - (autoload 'nnml-generate-nov-databases-1 "nnml") + (autoload 'nnml-generate-nov-databases-directory "nnml") (autoload 'nnvirtual-find-group-art "nnvirtual")) @@ -620,7 +620,6 @@ $ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache" (interactive) (let ((gnus-mark-article-hook nil) (gnus-expert-user t) - (nnmail-spool-file nil) (mail-sources nil) (gnus-use-dribble-file nil) (gnus-novice-user nil) @@ -756,7 +755,7 @@ If LOW, update the lower bound instead." (interactive (list gnus-cache-directory)) (gnus-cache-close) (let ((nnml-generate-active-function 'identity)) - (nnml-generate-nov-databases-1 dir)) + (nnml-generate-nov-databases-directory dir)) (setq gnus-cache-total-fetched-hashtb nil) diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 5d1b2b26a8e..908a75513e4 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -1170,10 +1170,9 @@ Returns nil if there is no such line before LIMIT, t otherwise." (setq count (1+ count)))))) ;; "Keywords for highlighting different levels of message citations.") -(eval-when-compile - (defvar font-lock-defaults-computed) - (defvar font-lock-keywords) - (defvar font-lock-set-defaults)) +(defvar font-lock-defaults-computed) +(defvar font-lock-keywords) +(defvar font-lock-set-defaults) (eval-and-compile (unless (featurep 'xemacs) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index 6d37120bd59..845a467c574 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -949,20 +949,18 @@ articles in the thread. (gnus-score-set 'touched '(t) alist)) (bury-buffer)) -(eval-when-compile - (defvar category-fields nil) - (defvar gnus-agent-cat-name) - (defvar gnus-agent-cat-score-file) - (defvar gnus-agent-cat-length-when-short) - (defvar gnus-agent-cat-length-when-long) - (defvar gnus-agent-cat-low-score) - (defvar gnus-agent-cat-high-score) - (defvar gnus-agent-cat-enable-expiration) - (defvar gnus-agent-cat-days-until-old) - (defvar gnus-agent-cat-predicate) - (defvar gnus-agent-cat-groups) - (defvar gnus-agent-cat-enable-undownloaded-faces) -) +(defvar category-fields nil) +(defvar gnus-agent-cat-name) +(defvar gnus-agent-cat-score-file) +(defvar gnus-agent-cat-length-when-short) +(defvar gnus-agent-cat-length-when-long) +(defvar gnus-agent-cat-low-score) +(defvar gnus-agent-cat-high-score) +(defvar gnus-agent-cat-enable-expiration) +(defvar gnus-agent-cat-days-until-old) +(defvar gnus-agent-cat-predicate) +(defvar gnus-agent-cat-groups) +(defvar gnus-agent-cat-enable-undownloaded-faces) (defun gnus-trim-whitespace (s) (when (string-match "\\`[ \n\t]+" s) diff --git a/lisp/gnus/gnus-demon.el b/lisp/gnus/gnus-demon.el index 98d098c51cf..421d4a07ee7 100644 --- a/lisp/gnus/gnus-demon.el +++ b/lisp/gnus/gnus-demon.el @@ -39,7 +39,7 @@ (autoload 'parse-time-string "parse-time" nil nil) (defgroup gnus-demon nil - "Demonic behaviour." + "Demonic behavior." :group 'gnus) (defcustom gnus-demon-handlers nil diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index fa9ef21bd1a..97e61a013c8 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -42,25 +42,55 @@ ;;; Code: (require 'dired) -(require 'gnus-ems) -(require 'gnus-msg) -(require 'gnus-util) -(require 'message) -(require 'mm-encode) -(require 'mml) +(autoload 'mml-attach-file "mml") +(autoload 'mm-default-file-encoding "mm-decode");; Shift this to `mailcap.el'? +(autoload 'mailcap-extension-to-mime "mailcap") +(autoload 'mailcap-mime-info "mailcap") + +;; Maybe shift this function to `mailcap.el'? +(autoload 'mm-mailcap-command "mm-decode") + +(autoload 'ps-print-preprint "ps-print") + +;; Autoloads to avoid byte-compiler warnings. These are used only if the user +;; customizes `gnus-dired-mail-mode' to use Message and/or Gnus. +(autoload 'message-buffers "message") +(autoload 'gnus-setup-message "gnus-msg") +(autoload 'gnus-print-buffer "gnus-sum") (defvar gnus-dired-mode nil - "Minor mode for intersections of gnus and dired.") + "Minor mode for intersections of MIME mail composition and dired.") (defvar gnus-dired-mode-map nil) (unless gnus-dired-mode-map (setq gnus-dired-mode-map (make-sparse-keymap)) - (gnus-define-keys gnus-dired-mode-map - "\C-c\C-m\C-a" gnus-dired-attach - "\C-c\C-m\C-l" gnus-dired-find-file-mailcap - "\C-c\C-m\C-p" gnus-dired-print)) + (define-key gnus-dired-mode-map "\C-c\C-m\C-a" 'gnus-dired-attach) + (define-key gnus-dired-mode-map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) + (define-key gnus-dired-mode-map "\C-c\C-m\C-p" 'gnus-dired-print)) + +;; FIXME: Make it customizable, change the default to `mail-user-agent' when +;; this file if renamed (e.g. to `dired-mime.el'). + +(defcustom gnus-dired-mail-mode 'gnus-user-agent ;; mail-user-agent + "Your preference for a mail composition package. +See `mail-user-agent' for more information." + :group 'mail ;; dired? + :version "23.0" ;; No Gnus + :type '(radio (function-item :tag "Default Emacs mail" + :format "%t\n" + sendmail-user-agent) + (function-item :tag "Emacs interface to MH" + :format "%t\n" + mh-e-user-agent) + (function-item :tag "Gnus Message package" + :format "%t\n" + message-user-agent) + (function-item :tag "Gnus Message with full Gnus features" + :format "%t\n" + gnus-user-agent) + (function :tag "Other"))) (defun gnus-dired-mode (&optional arg) "Minor mode for intersections of gnus and dired. @@ -73,14 +103,31 @@ (> (prefix-numeric-value arg) 0))) (when gnus-dired-mode (add-minor-mode 'gnus-dired-mode "" gnus-dired-mode-map) - (gnus-run-hooks 'gnus-dired-mode-hook)))) + (save-current-buffer + (run-hooks 'gnus-dired-mode-hook))))) ;;;###autoload (defun turn-on-gnus-dired-mode () "Convenience method to turn on gnus-dired-mode." + (interactive) (gnus-dired-mode 1)) -;; Method to attach files to a gnus composition. +(defun gnus-dired-mail-buffers () + "Return a list of active mail composition buffers." + (if (and (memq gnus-dired-mail-mode '(message-user-agent gnus-user-agent)) + (require 'message) + (fboundp 'message-buffers)) + (message-buffers) + ;; Cf. `message-buffers' in `message.el': + (let (buffers) + (save-excursion + (dolist (buffer (buffer-list t)) + (set-buffer buffer) + (when (eq major-mode 'mail-mode) + (push (buffer-name buffer) buffers)))) + (nreverse buffers)))) + +;; Method to attach files to a mail composition. (defun gnus-dired-attach (files-to-attach) "Attach dired's marked files to a gnus message composition. If called non-interactively, FILES-TO-ATTACH should be a list of @@ -102,22 +149,25 @@ filenames." (mapconcat (lambda (f) (file-name-nondirectory f)) files-to-attach ", ")) - (setq bufs (message-buffers)) + (setq bufs (gnus-dired-mail-buffers)) - ;; set up destination message buffer + ;; set up destination mail composition buffer (if (and bufs - (y-or-n-p "Attach files to existing message buffer? ")) + (y-or-n-p "Attach files to existing mail composition buffer? ")) (setq destination (if (= (length bufs) 1) (get-buffer (car bufs)) - (completing-read "Attach to which message buffer: " + (completing-read "Attach to which mail composition buffer: " (mapcar (lambda (b) (cons b (get-buffer b))) bufs) nil t))) - ;; setup a new gnus message buffer - (gnus-setup-message 'message (message-mail)) + ;; setup a new mail composition buffer + (if (eq gnus-dired-mail-mode 'gnus-user-agent) + (gnus-setup-message 'message (message-mail)) + ;; FIXME: Is this the right thing? + (compose-mail)) (setq destination (current-buffer))) ;; set buffer to destination buffer, and attach files @@ -151,7 +201,8 @@ If ARG is non-nil, open it in a new buffer." (setq method (cdr (assoc 'viewer (car (mailcap-mime-info mime-type - 'all))))))) + 'all + 'no-decode))))))) (let ((view-command (mm-mailcap-command method file-name nil))) (message "viewing via %s" view-command) (start-process "*display*" @@ -186,7 +237,8 @@ file to save in." (mailcap-extension-to-mime (match-string 0 file-name))) (stringp - (setq method (mailcap-mime-info mime-type "print")))) + (setq method (mailcap-mime-info mime-type "print" + 'no-decode)))) (call-process shell-file-name nil (generate-new-buffer " *mm*") nil @@ -194,7 +246,10 @@ file to save in." (mm-mailcap-command method file-name mime-type)) (with-temp-buffer (insert-file-contents file-name) - (gnus-print-buffer)) + (if (eq gnus-dired-mail-mode 'gnus-user-agent) + (gnus-print-buffer) + ;; FIXME: + (error "MIME print only implemeted via Gnus"))) (ps-despool print-to)))) ((file-symlink-p file-name) (error "File is a symlink to a nonexistent target")) diff --git a/lisp/gnus/gnus-ems.el b/lisp/gnus/gnus-ems.el index f37b1b73416..79e513b5f05 100644 --- a/lisp/gnus/gnus-ems.el +++ b/lisp/gnus/gnus-ems.el @@ -74,19 +74,18 @@ (defvar gnus-mouse-face-prop 'mouse-face "Property used for highlighting mouse regions."))) -(eval-when-compile - (defvar gnus-tmp-unread) - (defvar gnus-tmp-replied) - (defvar gnus-tmp-score-char) - (defvar gnus-tmp-indentation) - (defvar gnus-tmp-opening-bracket) - (defvar gnus-tmp-lines) - (defvar gnus-tmp-name) - (defvar gnus-tmp-closing-bracket) - (defvar gnus-tmp-subject-or-nil) - (defvar gnus-check-before-posting) - (defvar gnus-mouse-face) - (defvar gnus-group-buffer)) +(defvar gnus-tmp-unread) +(defvar gnus-tmp-replied) +(defvar gnus-tmp-score-char) +(defvar gnus-tmp-indentation) +(defvar gnus-tmp-opening-bracket) +(defvar gnus-tmp-lines) +(defvar gnus-tmp-name) +(defvar gnus-tmp-closing-bracket) +(defvar gnus-tmp-subject-or-nil) +(defvar gnus-check-before-posting) +(defvar gnus-mouse-face) +(defvar gnus-group-buffer) (defun gnus-ems-redefine () (cond diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 162cc7e1984..05454960e38 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -34,6 +34,8 @@ (require 'gnus-util) (require 'gnus) +(defvar gnus-face-properties-alist) + (defcustom gnus-x-face-directory (expand-file-name "x-faces" gnus-directory) "*Directory where X-Face PBM files are stored." :version "22.1" diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 942a1cf4947..5843214e48a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -28,8 +28,8 @@ ;;; Code: (eval-when-compile - (require 'cl) - (defvar tool-bar-mode)) + (require 'cl)) +(defvar tool-bar-mode) (require 'gnus) (require 'gnus-start) @@ -1655,6 +1655,24 @@ if it is a string, only list groups matching REGEXP." (ticked (gnus-range-length (cdr (assq 'tick marked)))) (group-age (gnus-group-timestamp-delta group)) (inhibit-read-only t)) + ;; FIXME: http://thread.gmane.org/gmane.emacs.gnus.general/65451/focus=65465 + ;; ====================================================================== + ;; From: Richard Stallman + ;; Subject: Re: Rewriting gnus-group-highlight-line (was: [...]) + ;; Cc: ding@gnus.org + ;; Date: Sat, 27 Oct 2007 19:41:20 -0400 + ;; Message-ID: <E1IlvHM-0006TS-7t@fencepost.gnu.org> + ;; + ;; [...] + ;; The kludge is that the alist elements contain expressions that refer + ;; to local variables with short names. Perhaps write your own tiny + ;; evaluator that handles just `and', `or', and numeric comparisons + ;; and just a few specific variables. + ;; ====================================================================== + ;; + ;; Similar for other evaluated variables. Grep for risky-local-variable + ;; to find them! -- rsteib + ;; ;; Eval the cars of the lists until we find a match. (while (and list (not (eval (caar list)))) @@ -2875,8 +2893,8 @@ If SOLID (the prefix), create a solid group." (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode) 'summary 'group)))))) +(defvar nnrss-group-alist) (eval-when-compile - (defvar nnrss-group-alist) (defun nnrss-discover-feed (arg)) (defun nnrss-save-server-data (arg))) (defun gnus-group-make-rss-group (&optional url) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 52b5e350653..ac2b7237866 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -36,6 +36,7 @@ (autoload 'gnus-agent-expire "gnus-agent") (autoload 'gnus-agent-regenerate-group "gnus-agent") (autoload 'gnus-agent-read-servers-validate-native "gnus-agent") +(autoload 'gnus-agent-possibly-synchronize-flags-server "gnus-agent") (defcustom gnus-open-server-hook nil "Hook called just before opening connection to the news server." @@ -278,6 +279,11 @@ If it is down, start it up (again)." ;; prompting with "go offline?". This is only a concern ;; when the agent's backend fails to open the server. (gnus-open-server gnus-command-method)) + (when (and (eq (cadr elem) 'ok) gnus-agent + (gnus-agent-method-p gnus-command-method)) + (save-excursion + (gnus-agent-possibly-synchronize-flags-server + gnus-command-method))) result))))) (defun gnus-close-server (gnus-command-method) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 5778a02e168..2d64a76b6c6 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -687,7 +687,6 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" (concat "options -n " (mapconcat 'identity command-line-args-left " ")))) (gnus-expert-user t) - (nnmail-spool-file nil) (mail-sources nil) (gnus-use-dribble-file nil) (gnus-batch-mode t) diff --git a/lisp/gnus/gnus-mh.el b/lisp/gnus/gnus-mh.el index 66321c0d3e8..48a85071e67 100644 --- a/lisp/gnus/gnus-mh.el +++ b/lisp/gnus/gnus-mh.el @@ -41,8 +41,7 @@ (require 'gnus-msg) (require 'gnus-sum) -(eval-when-compile - (defvar mh-lib-progs)) +(defvar mh-lib-progs) (defun gnus-summary-save-article-folder (&optional arg) "Append the current article to an mh folder. diff --git a/lisp/gnus/gnus-move.el b/lisp/gnus/gnus-move.el index 0a97f8d5bd6..cf5cde692ff 100644 --- a/lisp/gnus/gnus-move.el +++ b/lisp/gnus/gnus-move.el @@ -47,8 +47,7 @@ Update the .newsrc.eld file to reflect the change of nntp server." ;; First start Gnus. (let ((gnus-activate-level 0) - (mail-sources nil) - (nnmail-spool-file nil)) + (mail-sources nil)) (gnus)) (save-excursion diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 891ed1bc269..735b9ed629b 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -265,7 +265,7 @@ This can also be a function receiving the group name as the only parameter, which should return non-nil if a confirmation is needed; or a regexp, in which case a confirmation is asked for if the group name matches the regexp." - :version "22.1" + :version "23.0" ;; No Gnus (default changed) :group 'gnus-message :type '(choice (const :tag "No" nil) (const :tag "Yes" t) @@ -1101,7 +1101,10 @@ If VERY-WIDE, make a very wide reply." ((functionp gnus-confirm-mail-reply-to-news) (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name)) (t gnus-confirm-mail-reply-to-news))) - (y-or-n-p "Really reply by mail to article author? ")) + (if (or wide very-wide) + t ;; Ignore gnus-confirm-mail-reply-to-news for wide and very + ;; wide replies. + (y-or-n-p "Really reply by mail to article author? "))) (let* ((article (if (listp (car yank)) (caar yank) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 2ccf70efc46..d45cc6c5d6d 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -63,6 +63,8 @@ (require 'gnus-util) (require 'nnmail) +(defvar gnus-adaptive-word-syntax-table) + (defvar gnus-registry-dirty t "Boolean set to t when the registry is modified") diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index ca087f9ca4d..77e06ee04f8 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -280,7 +280,7 @@ The following commands are available: ;; Insert the text. (eval gnus-server-line-format-spec)) (list 'gnus-server (intern gnus-tmp-name) - 'gnus-named-server (intern (gnus-method-to-server method)))))) + 'gnus-named-server (intern (gnus-method-to-server method t)))))) (defun gnus-enter-server-buffer () "Set up the server buffer." diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 39de524b156..2c1b6677949 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -39,11 +39,11 @@ (autoload 'gnus-agent-possibly-alter-active "gnus-agent") (eval-when-compile - (require 'cl) + (require 'cl)) - (defvar gnus-agent-covered-methods nil) - (defvar gnus-agent-file-loading-local nil) - (defvar gnus-agent-file-loading-cache nil)) +(defvar gnus-agent-covered-methods) +(defvar gnus-agent-file-loading-local) +(defvar gnus-agent-file-loading-cache) (defcustom gnus-startup-file (nnheader-concat gnus-home-directory ".newsrc") "Your `.newsrc' file. @@ -652,21 +652,20 @@ the first newsgroup." ;;; General various misc type functions. ;; Silence byte-compiler. -(eval-when-compile - (defvar gnus-current-headers) - (defvar gnus-thread-indent-array) - (defvar gnus-newsgroup-name) - (defvar gnus-newsgroup-headers) - (defvar gnus-group-list-mode) - (defvar gnus-group-mark-positions) - (defvar gnus-newsgroup-data) - (defvar gnus-newsgroup-unreads) - (defvar nnoo-state-alist) - (defvar gnus-current-select-method) - (defvar mail-sources) - (defvar nnmail-scan-directory-mail-source-once) - (defvar nnmail-split-history) - (defvar nnmail-spool-file)) +(defvar gnus-current-headers) +(defvar gnus-thread-indent-array) +(defvar gnus-newsgroup-name) +(defvar gnus-newsgroup-headers) +(defvar gnus-group-list-mode) +(defvar gnus-group-mark-positions) +(defvar gnus-newsgroup-data) +(defvar gnus-newsgroup-unreads) +(defvar nnoo-state-alist) +(defvar gnus-current-select-method) +(defvar mail-sources) +(defvar nnmail-scan-directory-mail-source-once) +(defvar nnmail-split-history) +(defvar nnmail-spool-file) (defun gnus-close-all-servers () "Close all servers." @@ -1514,8 +1513,8 @@ newsgroup." (setq killed (cdr killed))))) ;; We want to inline a function from gnus-cache, so we cheat here: +(defvar gnus-cache-active-hashtb) (eval-when-compile - (defvar gnus-cache-active-hashtb) (defun gnus-cache-possibly-alter-active (group active) "Alter the ACTIVE info for GROUP to reflect the articles in the cache." (when gnus-cache-active-hashtb @@ -1672,7 +1671,7 @@ If SCAN, request a scan of that group as well." (defun gnus-get-unread-articles (&optional level) (setq gnus-server-method-cache nil) (let* ((newsrc (cdr gnus-newsrc-alist)) - (level (or level gnus-activate-level (1+ gnus-level-subscribed))) + (alevel (or level gnus-activate-level (1+ gnus-level-subscribed))) (foreign-level (min (cond ((and gnus-activate-foreign-newsgroups @@ -1681,11 +1680,11 @@ If SCAN, request a scan of that group as well." ((numberp gnus-activate-foreign-newsgroups) gnus-activate-foreign-newsgroups) (t 0)) - level)) + alevel)) (methods-cache nil) (type-cache nil) scanned-methods info group active method retrieve-groups cmethod - method-type ignore) + method-type) (gnus-message 6 "Checking new news...") (while newsrc @@ -1722,7 +1721,6 @@ If SCAN, request a scan of that group as well." 'foreign))) (push (cons method method-type) type-cache)) - (setq ignore nil) (cond ((and method (eq method-type 'foreign)) ;; These groups are foreign. Check the level. (if (<= (gnus-info-level info) foreign-level) @@ -1736,9 +1734,17 @@ If SCAN, request a scan of that group as well." (when (fboundp (intern (concat (symbol-name (car method)) "-request-update-info"))) (inline (gnus-request-update-info info method)))) - (setq ignore t))) + (if (and level + ;; If `active' is nil that means the group has + ;; never been read, the group should be marked + ;; as having never been checked (see below). + active + (> (gnus-info-level info) level)) + ;; Don't check groups of which levels are higher + ;; than the one that a user specified. + (setq active 'ignore)))) ;; These groups are native or secondary. - ((> (gnus-info-level info) level) + ((> (gnus-info-level info) alevel) ;; We don't want these groups. (setq active 'ignore)) ;; Activate groups. @@ -1758,11 +1764,7 @@ If SCAN, request a scan of that group as well." ;; not required. (if (and (or nnmail-scan-directory-mail-source-once - (null (assq 'directory - (or mail-sources - (if (listp nnmail-spool-file) - nnmail-spool-file - (list nnmail-spool-file)))))) + (null (assq 'directory mail-sources))) (member method scanned-methods)) (setq active (gnus-activate-group group)) (setq active (gnus-activate-group group 'scan)) @@ -1775,10 +1777,6 @@ If SCAN, request a scan of that group as well." ((eq active 'ignore) ;; Don't do anything. ) - ((and active ignore) - ;; The level of the foreign group is higher than the specified - ;; value. - ) (active (inline (gnus-get-unread-articles-in-group info active t))) (t @@ -2106,7 +2104,8 @@ If SCAN, request a scan of that group as well." (if (equal method gnus-select-method) (gnus-make-hashtable (count-lines (point-min) (point-max))) - (gnus-make-hashtable 4096))))))) + (gnus-make-hashtable 4096)))))) + group max min) ;; Delete unnecessary lines. (goto-char (point-min)) (cond @@ -2141,8 +2140,12 @@ If SCAN, request a scan of that group as well." (insert prefix) (zerop (forward-line 1))))))) ;; Store the active file in a hash table. - (goto-char (point-min)) - (let (group max min) + ;; Use a unibyte buffer in order to make `read' read non-ASCII + ;; group names (which have been encoded) as unibyte strings. + (mm-with-unibyte-buffer + (insert-buffer-substring cur) + (setq cur (current-buffer)) + (goto-char (point-min)) (while (not (eobp)) (condition-case () (progn diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index bc5ed9f0fb5..b082a8b152e 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -28,8 +28,10 @@ ;;; Code: (eval-when-compile - (require 'cl) - (defvar tool-bar-mode)) + (require 'cl)) + +(defvar tool-bar-mode) +(defvar gnus-tmp-header) (require 'gnus) (require 'gnus-group) @@ -2193,6 +2195,7 @@ increase the score of each group you read." "O" gnus-uu-decode-save "b" gnus-uu-decode-binhex "B" gnus-uu-decode-binhex + "Y" gnus-uu-decode-yenc "p" gnus-uu-decode-postscript "P" gnus-uu-decode-postscript-and-save) @@ -4954,7 +4957,6 @@ Unscored articles will be counted as having a score of zero." (defvar gnus-tmp-root-expunged nil) (defvar gnus-tmp-dummy-line nil) -(eval-when-compile (defvar gnus-tmp-header)) (defun gnus-extra-header (type &optional header) "Return the extra header of TYPE." (or (cdr (assq type (mail-header-extra (or header gnus-tmp-header)))) @@ -5592,8 +5594,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-get-predicate display))) ;; Uses the dynamically bound `number' variable. -(eval-when-compile - (defvar number)) +(defvar number) (defun gnus-article-marked-p (type &optional article) (let ((article (or article number))) (cond diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index cf174d90ac8..de01fb2db11 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -36,16 +36,16 @@ ;;; Code: (eval-when-compile - (require 'cl) - ;; Fixme: this should be a gnus variable, not nnmail-. - (defvar nnmail-pathname-coding-system) - (defvar nnmail-active-file-coding-system) - - ;; Inappropriate references to other parts of Gnus. - (defvar gnus-emphasize-whitespace-regexp) - (defvar gnus-original-article-buffer) - (defvar gnus-user-agent) - ) + (require 'cl)) +;; Fixme: this should be a gnus variable, not nnmail-. +(defvar nnmail-pathname-coding-system) +(defvar nnmail-active-file-coding-system) + +;; Inappropriate references to other parts of Gnus. +(defvar gnus-emphasize-whitespace-regexp) +(defvar gnus-original-article-buffer) +(defvar gnus-user-agent) + (require 'time-date) (require 'netrc) @@ -982,9 +982,10 @@ with potentially long computations." ;; version fails halfway, however it provides the rmail-select-summary ;; macro which uses the following functions: (autoload 'rmail-summary-displayed "rmail") - (autoload 'rmail-maybe-display-summary "rmail"))) - (defvar rmail-default-rmail-file) - (defvar mm-text-coding-system)) + (autoload 'rmail-maybe-display-summary "rmail")))) + +(defvar rmail-default-rmail-file) +(defvar mm-text-coding-system) (defun gnus-output-to-rmail (filename &optional ask) "Append the current article to an Rmail file named FILENAME." @@ -1551,8 +1552,7 @@ Return nil otherwise." display)) display))))) -(eval-when-compile - (defvar tool-bar-mode)) +(defvar tool-bar-mode) (defun gnus-tool-bar-update (&rest ignore) "Update the tool bar." @@ -1621,10 +1621,9 @@ predicate on the elements." (push (pop list1) res))) (nconc (nreverse res) list1 list2)))) -(eval-when-compile - (defvar xemacs-codename) - (defvar sxemacs-codename) - (defvar emacs-program-version)) +(defvar xemacs-codename) +(defvar sxemacs-codename) +(defvar emacs-program-version) (defun gnus-emacs-version () "Stringified Emacs version." diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 20937562096..3a045c2c234 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -35,6 +35,7 @@ (require 'message) (require 'gnus-msg) (require 'mm-decode) +(require 'yenc) (defgroup gnus-extract nil "Extracting encoded files." @@ -75,7 +76,7 @@ ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$" "gnus-uu-archive")) "*Default actions to be taken when the user asks to view a file. -To change the behaviour, you can either edit this variable or set +To change the behavior, you can either edit this variable or set `gnus-uu-user-view-rules' to something useful. For example: @@ -95,7 +96,7 @@ at that point in the command string. If there's no \"%s\" in the command string, the file name will be appended to the command string before executing. -There are several user variables to tailor the behaviour of gnus-uu to +There are several user variables to tailor the behavior of gnus-uu to your needs. First we have `gnus-uu-user-view-rules', which is the variable gnus-uu first consults when trying to decide how to view a file. If this variable contains no matches, gnus-uu examines the @@ -346,6 +347,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (defvar gnus-uu-file-name nil) (defvar gnus-uu-uudecode-process nil) (defvar gnus-uu-binhex-article-name nil) +(defvar gnus-uu-yenc-article-name nil) (defvar gnus-uu-work-dir nil) @@ -412,6 +414,17 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (mm-make-temp-file (expand-file-name "binhex" gnus-uu-work-dir))) (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir)) +(defun gnus-uu-decode-yenc (n dir) + "Decode the yEnc-encoded current article." + (interactive + (list current-prefix-arg + (file-name-as-directory + (read-file-name "yEnc decode and save in dir: " + gnus-uu-default-dir + gnus-uu-default-dir)))) + (setq gnus-uu-yenc-article-name nil) + (gnus-uu-decode-with-method 'gnus-uu-yenc-article n dir nil t)) + (defun gnus-uu-decode-uu-view (&optional n) "Uudecodes and views the current article." (interactive "P") @@ -1016,6 +1029,39 @@ When called interactively, prompt for REGEXP." (cons gnus-uu-binhex-article-name state) state))) +;; yEnc + +(defun gnus-uu-yenc-article (buffer in-state) + (save-excursion + (set-buffer gnus-original-article-buffer) + (widen) + (let ((file-name (yenc-extract-filename)) + state start-char) + (when (not file-name) + (setq state (list 'wrong-type))) + + (if (memq 'wrong-type state) + () + (when (yenc-first-part-p) + (setq gnus-uu-yenc-article-name + (expand-file-name file-name gnus-uu-work-dir)) + (push 'begin state)) + (when (yenc-last-part-p) + (push 'end state)) + (unless state + (push 'middle state)) + (mm-with-unibyte-buffer + (insert-buffer gnus-original-article-buffer) + (yenc-decode-region (point-min) (point-max)) + (when (and (member 'begin state) + (file-exists-p gnus-uu-yenc-article-name)) + (delete-file gnus-uu-yenc-article-name)) + (mm-append-to-file (point-min) (point-max) + gnus-uu-yenc-article-name))) + (if (memq 'begin state) + (cons file-name state) + state)))) + ;; PostScript (defun gnus-uu-decode-postscript-article (process-buffer in-state) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index b09511ea9c4..bd96e52d65f 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -43,6 +43,8 @@ (defvar gnus-spam-autodetect-methods) (defvar gnus-spam-newsgroup-contents) (defvar gnus-spam-process-destinations) +(defvar gnus-spam-resend-to) +(defvar gnus-ham-resend-to) (defvar gnus-spam-process-newsgroups) @@ -3519,15 +3521,16 @@ that that variable is buffer-local to the summary buffers." (nth 1 method)))) method))) -(defsubst gnus-method-to-server (method) +(defsubst gnus-method-to-server (method &optional nocache) (catch 'server-name (setq method (or method gnus-select-method)) ;; Perhaps it is already in the cache. - (mapc (lambda (name-method) - (if (equal (cdr name-method) method) - (throw 'server-name (car name-method)))) - gnus-server-method-cache) + (unless nocache + (mapc (lambda (name-method) + (if (equal (cdr name-method) method) + (throw 'server-name (car name-method)))) + gnus-server-method-cache)) (mapc (lambda (server-alist) @@ -4252,14 +4255,16 @@ Allow completion over sensible values." ;;; Agent functions -(defun gnus-agent-method-p (method) +(defun gnus-agent-method-p (method-or-server) "Say whether METHOD is covered by the agent." - (or (eq (car gnus-agent-method-p-cache) method) - (setq gnus-agent-method-p-cache - (cons method - (member (if (stringp method) - method - (gnus-method-to-server method)) gnus-agent-covered-methods)))) + (or (eq (car gnus-agent-method-p-cache) method-or-server) + (let* ((method (if (stringp method-or-server) + (gnus-server-to-method method-or-server) + method-or-server)) + (server (gnus-method-to-server method t))) + (setq gnus-agent-method-p-cache + (cons method-or-server + (member server gnus-agent-covered-methods))))) (cdr gnus-agent-method-p-cache)) (defun gnus-online (method) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index abf32756498..39595b767ad 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -27,18 +27,20 @@ ;;; Code: +(require 'format-spec) (eval-when-compile (require 'cl) - (require 'imap) - (eval-when-compile (defvar display-time-mail-function))) + (require 'imap)) (eval-and-compile (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (autoload 'nnheader-cancel-timer "nnheader")) -(require 'format-spec) (require 'mm-util) (require 'message) ;; for `message-directory' +(defvar display-time-mail-function) + + (defgroup mail-source nil "The mail-fetching library." :version "21.1" @@ -56,15 +58,16 @@ (list 'const (car a))) imap-stream-alist))) -(defcustom mail-sources nil - "*Where the mail backends will look for incoming mail. +(defcustom mail-sources '((file)) + "Where the mail backends will look for incoming mail. This variable is a list of mail source specifiers. See Info node `(gnus)Mail Source Specifiers'." :group 'mail-source + :version "23.0" ;; No Gnus :link '(custom-manual "(gnus)Mail Source Specifiers") :type `(choice - (const nil) - (repeat + (const :tag "None" nil) + (repeat :tag "List" (choice :format "%[Value Menu%] %v" :value (file) (cons :tag "Spool file" diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el index 6839a6472b7..063b2ec2f44 100644 --- a/lisp/gnus/mailcap.el +++ b/lisp/gnus/mailcap.el @@ -33,8 +33,14 @@ ;;; Code: (eval-when-compile (require 'cl)) -(require 'mail-parse) -(require 'mm-util) +(autoload 'mail-header-parse-content-type "mail-parse") + +;; `mm-delete-duplicates' is an alias for `delete-dups' in Emacs 22. +(defalias 'mailcap-delete-duplicates + (if (fboundp 'delete-dups) + 'delete-dups + (autoload 'mm-delete-duplicates "mm-util") + 'mm-delete-duplicates)) (defgroup mailcap nil "Definition of viewers for MIME types." @@ -722,7 +728,7 @@ If TEST is not given, it defaults to t." t) (t nil)))) -(defun mailcap-mime-info (string &optional request) +(defun mailcap-mime-info (string &optional request no-decode) "Get the MIME viewer command for STRING, return nil if none found. Expects a complete content-type header line as its argument. @@ -732,7 +738,11 @@ entry) will be returned. If it is a string, then the mailcap field corresponding to that string will be returned (print, description, whatever). If a number, then all the information for this specific viewer is returned. If `all', then all possible viewers for -this type is returned." +this type is returned. + +If NO-DECODE is non-nil, don't decode STRING." + ;; NO-DECODE avoids calling `mail-header-parse-content-type' from + ;; `mail-parse.el' (let ( major ; Major encoding (text, etc) minor ; Minor encoding (html, etc) @@ -746,7 +756,10 @@ this type is returned." viewer ; The one and only viewer ctl) (save-excursion - (setq ctl (mail-header-parse-content-type (or string "text/plain"))) + (setq ctl + (if no-decode + (list (or string "text/plain")) + (mail-header-parse-content-type (or string "text/plain")))) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) @@ -766,7 +779,7 @@ this type is returned." (setq viewer (car passed))) (cond ((and (null viewer) (not (equal major "default")) request) - (mailcap-mime-info "default" request)) + (mailcap-mime-info "default" request no-decode)) ((or (null request) (equal request "")) (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info)) ((stringp request) @@ -976,7 +989,7 @@ If FORCE, re-parse even if already parsed." (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) - (mm-delete-duplicates + (mailcap-delete-duplicates (nconc (mapcar 'cdr mailcap-mime-extensions) (apply diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 895c36a6beb..3aaa8c25745 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -32,9 +32,8 @@ ;;; Code: (eval-when-compile - (require 'cl) - (defvar gnus-message-group-art) - (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary + (require 'cl)) + (require 'hashcash) (require 'canlock) (require 'mailheader) @@ -51,6 +50,11 @@ (require 'rfc822) (require 'ecomplete) +(autoload 'mailclient-send-it "mailclient") ;; Emacs 22 or contrib/ + +(defvar gnus-message-group-art) +(defvar gnus-list-identifiers) ; gnus-sum is required where necessary +(defvar rmail-enable-mime-composing) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -269,7 +273,7 @@ included. Organization and User-Agent are optional." :link '(custom-manual "(message)Mail Headers") :type 'regexp) -(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-ID:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:" "*Header lines matching this regexp will be deleted before posting. It's best to delete old Path and Date headers before posting to avoid any confusion." @@ -474,8 +478,7 @@ This is used by `message-kill-buffer'." :group 'message-buffers :type 'boolean) -(eval-when-compile - (defvar gnus-local-organization)) +(defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) (stringp gnus-local-organization) @@ -585,21 +588,21 @@ Done before generating the new subject of a forward." :type 'regexp) (defcustom message-cite-prefix-regexp - (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+" + (if (string-match "[[:digit:]]" "1") + ;; Support POSIX? XEmacs 21.5.27 doesn't. + "\\([ \t]*[_.[:word:]]+>+\\|[ \t]*[]>|}]\\)+" ;; ?-, ?_ or ?. MUST NOT be in syntax entry w. (let (non-word-constituents) (with-syntax-table text-mode-syntax-table (setq non-word-constituents (concat - (if (string-match "\\w" "-") "" "-") (if (string-match "\\w" "_") "" "_") (if (string-match "\\w" ".") "" ".")))) (if (equal non-word-constituents "") - "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+" + "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}]\\)+" (concat "\\([ \t]*\\(\\w\\|[" non-word-constituents - "]\\)+>+\\|[ \t]*[]>|}+]\\)+")))) + "]\\)+>+\\|[ \t]*[]>|}]\\)+")))) "*Regexp matching the longest possible citation prefix on a line." :version "22.1" :group 'message-insertion @@ -618,28 +621,36 @@ Done before generating the new subject of a forward." :link '(custom-manual "(message)Canceling News") :type 'string) +(defvar smtpmail-default-smtp-server) + +(defun message-send-mail-function () + "Return suitable value for the variable `message-send-mail-function'." + (cond ((and (require 'sendmail) + (boundp 'sendmail-program) + sendmail-program + (executable-find sendmail-program)) + 'message-send-mail-with-sendmail) + ((and (locate-library "smtpmail") + (require 'smtpmail) + smtpmail-default-smtp-server) + 'message-smtpmail-send-it) + ((locate-library "mailclient") + 'message-send-mail-with-mailclient) + (t + (lambda () + (error "Don't know how to send mail. Please customize `message-send-mail-function'"))))) + ;; Useful to set in site-init.el -(defcustom message-send-mail-function - (let ((program (if (boundp 'sendmail-program) - ;; see paths.el - sendmail-program))) - (cond - ((and program - (string-match "/" program) ;; Skip path - (file-executable-p program)) - 'message-send-mail-with-sendmail) - ((and program - (executable-find program)) - 'message-send-mail-with-sendmail) - (t - 'smtpmail-send-it))) +(defcustom message-send-mail-function (message-send-mail-function) "Function to call to send the current buffer as mail. The headers should be delimited by a line whose contents match the variable `mail-header-separator'. -Valid values include `message-send-mail-with-sendmail' (the default), +Valid values include `message-send-mail-with-sendmail' `message-send-mail-with-mh', `message-send-mail-with-qmail', -`message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'. +`message-smtpmail-send-it', `smtpmail-send-it', +`feedmail-send-it' and `message-send-mail-with-mailclient'. The +default is system dependent. See also `send-mail-function'." :type '(radio (function-item message-send-mail-with-sendmail) @@ -648,8 +659,12 @@ See also `send-mail-function'." (function-item message-smtpmail-send-it) (function-item smtpmail-send-it) (function-item feedmail-send-it) - (function :tag "Other")) + (function :tag "Other") + (function-item message-send-mail-with-mailclient + :tag "Use Mailclient package") + (function :tag "Other")) :group 'message-sending + :initialize 'custom-initialize-default :link '(custom-manual "(message)Mail Variables") :group 'message-mail) @@ -816,9 +831,8 @@ might set this variable to '(\"-f\" \"you@some.where\")." :type '(choice (function) (repeat string))) -(eval-when-compile - (defvar gnus-post-method) - (defvar gnus-select-method)) +(defvar gnus-post-method) +(defvar gnus-select-method) (defcustom message-post-method (cond ((and (boundp 'gnus-post-method) (listp gnus-post-method) @@ -1122,8 +1136,7 @@ these lines." (file-readable-p "/etc/sendmail.cf") (let ((buffer (get-buffer-create " *temp*"))) (unwind-protect - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (insert-file-contents "/etc/sendmail.cf") (goto-char (point-min)) (let ((case-fold-search nil)) @@ -1205,7 +1218,7 @@ If nil, you might be asked to input the charset." (defcustom message-dont-reply-to-names (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names) "*Addresses to prune when doing wide replies. -This can be a regexp or a list of regexps. Also, a value of nil means +This can be a regexp or a list of regexps. Also, a value of nil means exclude your own user name only." :version "21.1" :group 'message @@ -1617,7 +1630,7 @@ functionality to work." (defcustom message-generate-hashcash (if (executable-find "hashcash") t) "*Whether to generate X-Hashcash: headers. -If `t', always generate hashcash headers. If `opportunistic', +If t, always generate hashcash headers. If `opportunistic', only generate hashcash headers if it can be done without the user waiting (i.e., only asynchronously). @@ -1640,9 +1653,8 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (defvar message-inserted-headers nil) ;; Byte-compiler warning -(eval-when-compile - (defvar gnus-active-hashtb) - (defvar gnus-read-active-file)) +(defvar gnus-active-hashtb) +(defvar gnus-read-active-file) ;;; Regexp matching the delimiter of messages in UNIX mail format ;;; (UNIX From lines), minus the initial ^. It should be a copy @@ -1916,8 +1928,7 @@ see `message-narrow-to-headers-or-head'." "Evaluate FORMS in the reply buffer, if it exists." `(when (and message-reply-buffer (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) + (with-current-buffer message-reply-buffer ,@forms))) (put 'message-with-reply-buffer 'lisp-indent-function 0) @@ -2662,9 +2673,8 @@ Prefixed with two \\[universal-argument]'s, display the PGG manual." (defvar message-tool-bar-map nil) -(eval-when-compile - (defvar facemenu-add-face-function) - (defvar facemenu-remove-face-function)) +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) ;;; Forbidden properties ;; @@ -3084,8 +3094,7 @@ or in the synonym headers, defined by `message-header-synonyms'." (let ((follow-to (and message-reply-buffer (buffer-name message-reply-buffer) - (save-excursion - (set-buffer message-reply-buffer) + (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) (save-excursion (save-restriction @@ -3337,8 +3346,7 @@ The three allowed values according to RFC 1327 are `high', `normal' and `low'." (interactive) (save-excursion - (let ((valid '("high" "normal" "low")) - (new "high") + (let ((new "high") cur) (save-restriction (message-narrow-to-headers) @@ -3612,7 +3620,7 @@ Really top post? "))) (defun message-buffers () "Return a list of active message buffers." (let (buffers) - (save-excursion + (save-current-buffer (dolist (buffer (buffer-list t)) (set-buffer buffer) (when (and (eq major-mode 'message-mode) @@ -3620,8 +3628,6 @@ Really top post? "))) (push (buffer-name buffer) buffers)))) (nreverse buffers))) -(eval-when-compile (defvar mail-citation-hook)) ; Compiler directive - (defun message-cite-original-1 (strip-signature) "Cite an original message. If STRIP-SIGNATURE is non-nil, strips off the signature from the @@ -3688,6 +3694,8 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) +(defvar gnus-extract-address-components) + (defun message-insert-formatted-citation-line (&optional from date) "Function that inserts a formatted citation line. @@ -4304,8 +4312,7 @@ This function could be useful in `message-setup-hook'." ;; Let the user do all of the above. (run-hooks 'message-header-hook)) (unwind-protect - (save-excursion - (set-buffer tembuf) + (with-current-buffer tembuf (erase-buffer) ;; Avoid copying text props (except hard newlines). (insert (with-current-buffer mailbuf @@ -4450,8 +4457,7 @@ If you always want Gnus to send messages in one piece, set (unless (or (null cpr) (and (numberp cpr) (zerop cpr))) (error "Sending...failed with exit value %d" cpr))) (when message-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (goto-char (point-min)) (while (re-search-forward "\n+ *" nil t) (replace-match "; ")) @@ -4532,6 +4538,13 @@ manual for details." (run-hooks 'message-send-mail-hook) (smtpmail-send-it)) +(defun message-send-mail-with-mailclient () + "Send the prepared message buffer with `mailclient-send-it'. +This only differs from `smtpmail-send-it' that this command evaluates +`message-send-mail-hook' just before sending a message." + (run-hooks 'message-send-mail-hook) + (mailclient-send-it)) + (defun message-canlock-generate () "Return a string that is non-trivial to guess. Do not use this for anything important, it is cryptographically weak." @@ -4614,8 +4627,7 @@ Otherwise, generate and save a value for `canlock-password' first." (message-check-news-syntax))) nil (unwind-protect - (save-excursion - (set-buffer tembuf) + (with-current-buffer tembuf (buffer-disable-undo) (erase-buffer) ;; Avoid copying text props (except hard newlines). @@ -5278,8 +5290,7 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." "Return the References header for this message." (when message-reply-headers (let ((message-id (mail-header-message-id message-reply-headers)) - (references (mail-header-references message-reply-headers)) - new-references) + (references (mail-header-references message-reply-headers))) (if (or references message-id) (concat (or references "") (and references " ") (or message-id "")) @@ -5527,8 +5538,7 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar 'funcall message-subscribed-address-functions)))) (save-match-data - (let ((subscribed-lists nil) - (list + (let ((list (loop for recipient in recipients when (loop for regexp in mft-regexps when (string-match regexp recipient) return t) @@ -5549,7 +5559,9 @@ subscribed address (and not the additional To and Cc header contents)." (mapcar 'downcase (mapcar 'car (mail-header-parse-addresses field)))))) - (setq ace (downcase (idna-to-ascii rhs))) + (setq ace (if (string-match "\\`[[:ascii:]]+\\'" rhs) + rhs + (downcase (idna-to-ascii rhs)))) (when (and (not (equal rhs ace)) (or (not (eq message-use-idna 'ask)) (y-or-n-p (format "Replace %s with %s in %s:? " @@ -6873,8 +6885,7 @@ the message." (setq subject (funcall func subject)))) subject)))) -(eval-when-compile - (defvar gnus-article-decoded-p)) +(defvar gnus-article-decoded-p) ;;;###autoload @@ -7088,8 +7099,6 @@ is for the internal use." (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) -(eval-when-compile (defvar rmail-enable-mime-composing)) - ;; Fixme: Should have defcustom. ;;;###autoload (defun message-insinuate-rmail () @@ -7311,8 +7320,7 @@ which specify the range to operate on." (mapcar #'delete-overlay (overlays-in (point-min) (point-max))))) ;; Support for toolbar -(eval-when-compile - (defvar tool-bar-mode)) +(defvar tool-bar-mode) ;; Note: The :set function in the `message-tool-bar*' variables will only ;; affect _new_ message buffers. We might add a function that walks thru all @@ -7377,7 +7385,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail_send") + (message-send-and-exit "gnus/mail-send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) @@ -7556,9 +7564,8 @@ The following arguments may contain lists of values." (if (and show (setq text (message-flatten-list text))) (save-window-excursion - (save-excursion - (with-output-to-temp-buffer " *MESSAGE information message*" - (set-buffer " *MESSAGE information message*") + (with-output-to-temp-buffer " *MESSAGE information message*" + (with-current-buffer " *MESSAGE information message*" (fundamental-mode) ; for Emacs 20.4+ (mapc 'princ text) (goto-char (point-min)))) @@ -7581,16 +7588,13 @@ Then clone the local variables and values from the old buffer to the new one, cloning only the locals having a substring matching the regexp VARSTR." (let ((oldbuf (current-buffer))) - (save-excursion - (set-buffer (generate-new-buffer name)) + (with-current-buffer (generate-new-buffer name) (message-clone-locals oldbuf varstr) (current-buffer)))) (defun message-clone-locals (buffer &optional varstr) "Clone the local variables from BUFFER to the current buffer." - (let ((locals (save-excursion - (set-buffer buffer) - (buffer-local-variables))) + (let ((locals (with-current-buffer buffer (buffer-local-variables))) (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address")) (mapcar (lambda (local) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 20af36564f7..0560c51ba41 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -26,14 +26,14 @@ ;;; Code: -(eval-when-compile - (defvar mm-uu-decode-function) - (defvar mm-uu-binhex-decode-function)) - (require 'mm-util) (require 'rfc2047) (require 'mm-encode) +(defvar mm-uu-yenc-decode-function) +(defvar mm-uu-decode-function) +(defvar mm-uu-binhex-decode-function) + ;; 8bit treatment gets any char except: 0x32 - 0x7f, LF, TAB, BEL, ;; BS, vertical TAB, form feed, and ^_ ;; @@ -170,8 +170,6 @@ If no encoding was done, nil is returned." ;;; Functions for decoding ;;; -(eval-when-compile (defvar mm-uu-yenc-decode-function)) - (defun mm-decode-content-transfer-encoding (encoding &optional type) "Decodes buffer encoded with ENCODING, returning success status. If TYPE is `text/plain' CRLF->LF translation may occur." diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 14e5c255d2a..71ef9bcdf55 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -895,7 +895,7 @@ external if displayed external." ;; a vector in Emacs but is a list in XEmacs) ;; requires that it is lexically scoped. (timer (run-at-time 2.0 nil 'ignore))) - (if (boundp 'itimer-list) + (if (featurep 'xemacs) (lambda (process state) (when (eq 'exit (process-status process)) (if (memq timer itimer-list) @@ -1364,34 +1364,35 @@ be determined." (mm-handle-set-cache handle spec)))))) (defun mm-create-image-xemacs (type) - (cond - ((equal type "xbm") - ;; xbm images require special handling, since - ;; the only way to create glyphs from these - ;; (without a ton of work) is to write them - ;; out to a file, and then create a file - ;; specifier. - (let ((file (mm-make-temp-file - (expand-file-name "emm" mm-tmp-directory) - nil ".xbm"))) - (unwind-protect - (progn - (write-region (point-min) (point-max) file) - (make-glyph (list (cons 'x file)))) - (ignore-errors - (delete-file file))))) - (t - (make-glyph - (vector - (or (mm-image-type-from-buffer) - (intern type)) - :data (buffer-string)))))) + (when (featurep 'xemacs) + (cond + ((equal type "xbm") + ;; xbm images require special handling, since + ;; the only way to create glyphs from these + ;; (without a ton of work) is to write them + ;; out to a file, and then create a file + ;; specifier. + (let ((file (mm-make-temp-file + (expand-file-name "emm" mm-tmp-directory) + nil ".xbm"))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file) + (make-glyph (list (cons 'x file)))) + (ignore-errors + (delete-file file))))) + (t + (make-glyph + (vector + (or (mm-image-type-from-buffer) + (intern type)) + :data (buffer-string))))))) (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) (or (not image) - (if (fboundp 'glyph-width) + (if (featurep 'xemacs) ;; XEmacs' glyphs can actually tell us about their width, so ;; lets be nice and smart about them. (or mm-inline-large-images diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index cfc6c949be0..edb7521dbf3 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -36,6 +36,8 @@ (require 'timer)) (require 'timer))) +(defvar mm-mime-mule-charset-alist ) + (eval-and-compile (mapc (lambda (elem) @@ -837,9 +839,10 @@ This affects whether coding conversion should be attempted generally." (autoload 'latin-unity-massage-name "latin-unity") (autoload 'latin-unity-maybe-remap "latin-unity") (autoload 'latin-unity-representations-feasible-region "latin-unity") - (autoload 'latin-unity-representations-present-region "latin-unity") - (defvar latin-unity-coding-systems) - (defvar latin-unity-ucs-list)) + (autoload 'latin-unity-representations-present-region "latin-unity")) + +(defvar latin-unity-coding-systems) +(defvar latin-unity-ucs-list) (defun mm-xemacs-find-mime-charset-1 (begin end) "Determine which MIME charset to use to send region as message. @@ -1375,7 +1378,7 @@ gzip, bzip2, etc. are allowed." (funcall (symbol-value 'set-auto-coding-function) nil (- (point-max) (point-min))) (error nil))))) - ((featurep 'file-coding) ;; XEmacs + ((and (featurep 'xemacs) (featurep 'file-coding)) ;; XEmacs (let ((case-fold-search t) (end (point-at-eol)) codesys start) diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index c7f6b16a1c8..52d47b728ef 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -272,7 +272,7 @@ If PROPERTIES is non-nil, PROPERTIES are applied to the buffer, see `set-text-properties'. If PROPERTIES equals t, this means to apply the face `mm-uu-extract'." (let ((obuf (current-buffer)) - (coding-system + (coding-system ;; Might not exist in non-MULE XEmacs (when (boundp 'buffer-file-coding-system) buffer-file-coding-system))) @@ -305,11 +305,10 @@ apply the face `mm-uu-extract'." (mm-uu-configure) -(eval-when-compile - (defvar file-name) - (defvar start-point) - (defvar end-point) - (defvar entry)) +(defvar file-name) +(defvar start-point) +(defvar end-point) +(defvar entry) (defun mm-uu-uu-filename () (if (looking-at ".+") @@ -375,8 +374,7 @@ apply the face `mm-uu-extract'." (list mm-dissect-disposition (cons 'filename file-name)))) -(eval-when-compile - (defvar gnus-newsgroup-name)) +(defvar gnus-newsgroup-name) (defun mm-uu-emacs-sources-test () (setq file-name (match-string 1)) @@ -430,7 +428,12 @@ apply the face `mm-uu-extract'." (cons 'filename file-name))))) (defun mm-uu-yenc-extract () - (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) + ;; This might not be exactly correct, but we sure can't get the + ;; binary data from the article buffer, since that's already in a + ;; non-binary charset. So get it from the original article buffer. + (mm-make-handle (save-excursion + (set-buffer gnus-original-article-buffer) + (mm-uu-copy-to-buffer start-point end-point)) (list (or (and file-name (string-match "\\.[^\\.]+$" file-name) (mailcap-extension-to-mime @@ -465,8 +468,7 @@ apply the face `mm-uu-extract'." (y-or-n-p "Verify pgp signed part? ") (message "")))))) -(eval-when-compile - (defvar gnus-newsgroup-charset)) +(defvar gnus-newsgroup-charset) (defun mm-uu-pgp-signed-extract-1 (handles ctl) (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index ffaf0ed68ba..cb4f42dabcf 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -97,19 +97,20 @@ (delete-region b (+ b 2))))))) (defun mm-inline-image-xemacs (handle) - (insert "\n\n") - (forward-char -2) - (let ((annot (make-annotation (mm-get-image handle) nil 'text)) - buffer-read-only) - (mm-handle-set-undisplayer - handle - `(lambda () - (let ((b ,(point-marker)) - buffer-read-only) - (delete-annotation ,annot) - (delete-region (- b 2) b)))) - (set-extent-property annot 'mm t) - (set-extent-property annot 'duplicable t))) + (when (featurep 'xemacs) + (insert "\n\n") + (forward-char -2) + (let ((annot (make-annotation (mm-get-image handle) nil 'text)) + buffer-read-only) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((b ,(point-marker)) + buffer-read-only) + (delete-annotation ,annot) + (delete-region (- b 2) b)))) + (set-extent-property annot 'mm t) + (set-extent-property annot 'duplicable t)))) (eval-and-compile (if (featurep 'xemacs) @@ -568,7 +569,7 @@ ;; By default, XEmacs font-lock uses non-duplicable text ;; properties. This code forces all the text properties ;; to be copied along with the text. - (when (fboundp 'extent-list) + (when (featurep 'xemacs) (map-extents (lambda (ext ignored) (set-extent-property ext 'duplicable t) nil) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 29bc0d41a1b..e7ecc06164f 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -27,7 +27,9 @@ ;;; Code: (eval-when-compile (require 'cl)) -(require 'password) +(or (require 'password-cache nil t) + (require 'password)) + (autoload 'mml2015-sign "mml2015") (autoload 'mml2015-encrypt "mml2015") (autoload 'mml1991-sign "mml1991") diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index c00ac416b8b..07dc1ab4ccb 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -142,6 +142,8 @@ Whether the passphrase is cached at all is controlled by nil)) (goto-char (point-max))) +(defvar gnus-extract-address-components) + (defun mml-smime-openssl-sign-query () ;; query information (what certificate) from user when MML tag is ;; added, for use later by the signing process @@ -298,13 +300,13 @@ Whether the passphrase is cached at all is controlled by (defun mml-smime-openssl-verify-test (handle ctl) smime-openssl-program) -(eval-and-compile - (autoload 'epg-make-context "epg")) +(defvar epg-user-id-alist) +(defvar epg-digest-algorithm-alist) +(defvar inhibit-redisplay) +(defvar password-cache-expiry) (eval-when-compile - (defvar epg-user-id-alist) - (defvar epg-digest-algorithm-alist) - (defvar inhibit-redisplay) + (autoload 'epg-make-context "epg") (autoload 'epg-context-set-armor "epg") (autoload 'epg-context-set-signers "epg") (autoload 'epg-context-result-for "epg") @@ -321,12 +323,6 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa")) -(eval-when-compile - (defvar password-cache-expiry) - (autoload 'password-read "password") - (autoload 'password-cache-add "password") - (autoload 'password-cache-remove "password")) - (defvar mml-smime-epg-secret-key-id-list nil) (defun mml-smime-epg-passphrase-callback (context key-id ignore) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 7fbc8bb3209..c5b7796ffaf 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -53,6 +53,7 @@ (defvar message-required-mail-headers) (defvar message-required-news-headers) (defvar dnd-protocol-alist) +(defvar mml-dnd-protocol-alist) (defcustom mml-content-type-parameters '(name access-type expiration size permission format) @@ -806,9 +807,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (mail-header-encode-parameter (symbol-name type) value)))))) -(eval-when-compile - (defvar ange-ftp-name-format) - (defvar efs-path-regexp)) +(defvar ange-ftp-name-format) +(defvar efs-path-regexp) + (defun mml-parse-file-name (path) (if (if (boundp 'efs-path-regexp) (string-match efs-path-regexp path) diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el index f6d2dcc7ad5..be9981676e6 100644 --- a/lisp/gnus/mml1991.el +++ b/lisp/gnus/mml1991.el @@ -244,10 +244,9 @@ Whether the passphrase is cached at all is controlled by ;; pgg wrapper -(eval-when-compile - (defvar pgg-default-user-id) - (defvar pgg-errors-buffer) - (defvar pgg-output-buffer)) +(defvar pgg-default-user-id) +(defvar pgg-errors-buffer) +(defvar pgg-output-buffer) (defun mml1991-pgg-sign (cont) (let ((pgg-text-mode t) @@ -313,11 +312,11 @@ Whether the passphrase is cached at all is controlled by ;; epg wrapper -(eval-and-compile - (autoload 'epg-make-context "epg")) +(defvar epg-user-id-alist) +(defvar password-cache-expiry) -(eval-when-compile - (defvar epg-user-id-alist) +(eval-and-compile + (autoload 'epg-make-context "epg") (autoload 'epg-passphrase-callback-function "epg") (autoload 'epa-select-keys "epa") (autoload 'epg-list-keys "epg") @@ -330,12 +329,6 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-configuration "epg-config") (autoload 'epg-expand-group "epg-config")) -(eval-when-compile - (defvar password-cache-expiry) - (autoload 'password-read "password") - (autoload 'password-cache-add "password") - (autoload 'password-cache-remove "password")) - (defvar mml1991-epg-secret-key-id-list nil) (defun mml1991-epg-passphrase-callback (context key-id ignore) diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 1760e4615ce..28d1929399e 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -173,9 +173,8 @@ Whether the passphrase is cached at all is controlled by (autoload 'mc-cleanup-recipient-headers "mc-toplev") (autoload 'mc-sign-generic "mc-toplev")) -(eval-when-compile - (defvar mc-default-scheme) - (defvar mc-schemes)) +(defvar mc-default-scheme) +(defvar mc-schemes) (defvar mml2015-decrypt-function 'mailcrypt-decrypt) (defvar mml2015-verify-function 'mailcrypt-verify) @@ -707,10 +706,9 @@ Whether the passphrase is cached at all is controlled by ;;; pgg wrapper -(eval-when-compile - (defvar pgg-default-user-id) - (defvar pgg-errors-buffer) - (defvar pgg-output-buffer)) +(defvar pgg-default-user-id) +(defvar pgg-errors-buffer) +(defvar pgg-output-buffer) (eval-and-compile (autoload 'pgg-decrypt-region "pgg") @@ -945,13 +943,12 @@ Whether the passphrase is cached at all is controlled by ;;; epg wrapper -(eval-and-compile - (autoload 'epg-make-context "epg")) +(defvar epg-user-id-alist) +(defvar epg-digest-algorithm-alist) +(defvar inhibit-redisplay) -(eval-when-compile - (defvar epg-user-id-alist) - (defvar epg-digest-algorithm-alist) - (defvar inhibit-redisplay) +(eval-and-compile + (autoload 'epg-make-context "epg") (autoload 'epg-context-set-armor "epg") (autoload 'epg-context-set-textmode "epg") (autoload 'epg-context-set-signers "epg") @@ -972,11 +969,7 @@ Whether the passphrase is cached at all is controlled by (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa")) -(eval-when-compile - (defvar password-cache-expiry) - (autoload 'password-read "password") - (autoload 'password-cache-add "password") - (autoload 'password-cache-remove "password")) +(defvar password-cache-expiry) (defvar mml2015-epg-secret-key-id-list nil) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 015c0643893..3767828a766 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1085,7 +1085,7 @@ all. This may very well take some time.") (unless no-active (nnmail-save-active nndiary-group-alist nndiary-active-file)))))) -(eval-when-compile (defvar files)) +(defvar files) (defun nndiary-generate-active-info (dir) ;; Update the active info for this group. (let* ((group (nnheader-file-to-group diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 031d2c3d0fb..11cb4bff55c 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -32,6 +32,9 @@ (eval-when-compile (require 'cl)) (defvar nnmail-extra-headers) +(defvar gnus-newsgroup-name) +(defvar nnheader-file-coding-system) +(defvar jka-compr-compression-info-list) ;; Requiring `gnus-util' at compile time creates a circular ;; dependency between nnheader.el and gnus-util.el. @@ -696,7 +699,6 @@ the line could be found." (erase-buffer)) (current-buffer)) -(eval-when-compile (defvar jka-compr-compression-info-list)) (defvar nnheader-numerical-files (if (boundp 'jka-compr-compression-info-list) (concat "\\([0-9]+\\)\\(" @@ -939,9 +941,8 @@ first. Otherwise, find the newest one, though it may take a time." (car results) (car (sort results 'file-newer-than-file-p))))) -(eval-when-compile - (defvar ange-ftp-path-format) - (defvar efs-path-regexp)) +(defvar ange-ftp-path-format) +(defvar efs-path-regexp) (defun nnheader-re-read-dir (path) "Re-read directory PATH if PATH is on a remote system." (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp)) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 28938e4c0a6..9b0fab70469 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -208,7 +208,7 @@ This is generally not required, and will slow things down considerably. You may need it if you want to use an advanced splitting function that analyzes the body before splitting the article. If this variable is nil, bodies will not be downloaded; if this -variable is the symbol `default' the default behaviour is +variable is the symbol `default' the default behavior is used (which currently is nil, unless you use a statistical spam.el test); if this variable is another non-nil value bodies will be downloaded." diff --git a/lisp/gnus/nnkiboze.el b/lisp/gnus/nnkiboze.el index 78e35c410bb..06acca8c09d 100644 --- a/lisp/gnus/nnkiboze.el +++ b/lisp/gnus/nnkiboze.el @@ -198,8 +198,7 @@ "\"Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups\". Finds out what articles are to be part of the nnkiboze groups." (interactive) - (let ((nnmail-spool-file nil) - (mail-sources nil) + (let ((mail-sources nil) (gnus-use-dribble-file nil) (gnus-read-active-file t) (gnus-expert-user t)) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 7608660f019..e05c286b1ab 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -240,16 +240,11 @@ If non-nil, also update the cache when copy or move articles." :group 'nnmail :type 'boolean) -(defcustom nnmail-spool-file '((file)) - "*Where the mail backends will look for incoming mail. -This variable is a list of mail source specifiers. -This variable is obsolete; `mail-sources' should be used instead." - :group 'nnmail-files - :type 'sexp) (make-obsolete-variable 'nnmail-spool-file "This option is obsolete in Gnus 5.9. \ Use `mail-sources' instead.") ;; revision 5.29 / p0-85 / Gnus 5.9 +;; Variable removed in No Gnus v0.7 (defcustom nnmail-resplit-incoming nil "*If non-nil, re-split incoming procmail sorted mail." @@ -693,7 +688,7 @@ nn*-request-list should have been called before calling this function." (setq group (symbol-name group))) (if (and (numberp (setq max (read buffer))) (numberp (setq min (read buffer)))) - (push (list group (cons min max)) + (push (list (mm-string-as-unibyte group) (cons min max)) group-assoc))) (error nil)) (widen) @@ -708,6 +703,7 @@ nn*-request-list should have been called before calling this function." (let ((coding-system-for-write nnmail-active-file-coding-system)) (when file-name (with-temp-file file-name + (mm-disable-multibyte) (nnmail-generate-active group-assoc))))) (defun nnmail-generate-active (alist) @@ -1764,10 +1760,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (defun nnmail-get-new-mail (method exit-func temp &optional group spool-func) "Read new incoming mail." - (let* ((sources (or mail-sources - (if (listp nnmail-spool-file) - nnmail-spool-file - (list nnmail-spool-file)))) + (let* ((sources mail-sources) fetching-sources (group-in group) (i 0) @@ -1777,20 +1770,6 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (when (and (nnmail-get-value "%s-get-new-mail" method) sources) (while (setq source (pop sources)) - ;; Be compatible with old values. - (cond - ((stringp source) - (setq source - (cond - ((string-match "^po:" source) - (list 'pop :user (substring source (match-end 0)))) - ((file-directory-p source) - (list 'directory :path source)) - (t - (list 'file :path source))))) - ((eq source 'procmail) - (message "Invalid value for nnmail-spool-file: `procmail'") - nil)) ;; Hack to only fetch the contents of a single group's spool file. (when (and (eq (car source) 'directory) (null nnmail-scan-directory-mail-source-once) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 04b6af72aed..e7674168484 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1,5 +1,6 @@ ;;; nnmaildir.el --- maildir backend for Gnus -;; Public domain. + +;; This file is in the public domain. ;; Author: Paul Jarc <prj@po.cwru.edu> diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 0f159181026..8a5afbe5b60 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -258,7 +258,8 @@ non-nil.") (string-to-number (file-name-nondirectory path))))))) (deffoo nnml-request-group (group &optional server dont-check) - (let ((file-name-coding-system nnmail-pathname-coding-system)) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (decoded (nnml-decoded-group-name group server))) (cond ((not (nnml-possibly-change-directory group server)) (nnheader-report 'nnml "Invalid group (no such directory)")) @@ -268,15 +269,15 @@ non-nil.") ((not (file-directory-p nnml-current-directory)) (nnheader-report 'nnml "%s is not a directory" nnml-current-directory)) (dont-check - (nnheader-report 'nnml "Group %s selected" group) + (nnheader-report 'nnml "Group %s selected" decoded) t) (t (nnheader-re-read-dir nnml-current-directory) (nnmail-activate 'nnml) (let ((active (nth 1 (assoc group nnml-group-alist)))) (if (not active) - (nnheader-report 'nnml "No such group: %s" group) - (nnheader-report 'nnml "Selected group %s" group) + (nnheader-report 'nnml "No such group: %s" decoded) + (nnheader-report 'nnml "Selected group %s" decoded) (nnheader-insert "211 %d %d %d %s\n" (max (1+ (- (cdr active) (car active))) 0) (car active) (cdr active) group))))))) @@ -885,7 +886,7 @@ Unless no-active is non-nil, update the active file too." (unless no-active (nnmail-save-active nnml-group-alist nnml-active-file))))))) -(eval-when-compile (defvar files)) +(defvar files) (defun nnml-generate-active-info (dir) ;; Update the active info for this group. (let ((group (directory-file-name dir)) diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el index 926553365d3..5c5e3c1af91 100644 --- a/lisp/gnus/nnnil.el +++ b/lisp/gnus/nnnil.el @@ -1,8 +1,11 @@ ;;; nnnil.el --- empty backend for Gnus -;; Public domain. + +;; This file is in the public domain. ;; Author: Paul Jarc <prj@po.cwru.edu> +;; This file is part of GNU Emacs. + ;; GNU Emacs 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 3, or (at your option) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 5241f9d80e6..f72166b0455 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -195,9 +195,8 @@ used to render text. If it is nil, text will simply be folded.") (deffoo nnrss-close-group (group &optional server) t) -(eval-when-compile - (defvar mm-text-html-renderer) - (defvar mm-text-html-washer-alist)) +(defvar mm-text-html-renderer) +(defvar mm-text-html-washer-alist) (deffoo nnrss-request-article (article &optional group server buffer) (setq group (nnrss-decode-group-name group)) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index c8c14da4df7..356ffefddeb 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -364,6 +364,32 @@ be restored and the command retried." (throw 'nntp-with-open-group-error t)) +(defmacro nntp-insert-buffer-substring (buffer &optional start end) + "Copy string from unibyte buffer to multibyte current buffer." + (if (featurep 'xemacs) + `(insert-buffer-substring ,buffer ,start ,end) + `(if enable-multibyte-characters + (insert (with-current-buffer ,buffer + (mm-string-to-multibyte + ,(if (or start end) + `(buffer-substring (or ,start (point-min)) + (or ,end (point-max))) + '(buffer-string))))) + (insert-buffer-substring ,buffer ,start ,end)))) + +(defmacro nntp-copy-to-buffer (buffer start end) + "Copy string from unibyte current buffer to multibyte buffer." + (if (featurep 'xemacs) + `(copy-to-buffer ,buffer ,start ,end) + `(let ((string (buffer-substring ,start ,end))) + (with-current-buffer ,buffer + (erase-buffer) + (insert (if enable-multibyte-characters + (mm-string-to-multibyte string) + string)) + (goto-char (point-min)) + nil)))) + (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." @@ -409,7 +435,7 @@ be restored and the command retried." (save-excursion (set-buffer buffer) (goto-char (point-max)) - (insert-buffer-substring (process-buffer process)) + (nntp-insert-buffer-substring (process-buffer process)) ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) @@ -653,7 +679,7 @@ command whose response triggered the error." nntp-server-buffer)) (buffer (and process (process-buffer process)))) - ;; When I an able to identify the + ;; When I am able to identify the ;; connection to the server AND I've ;; received NO reponse for ;; nntp-connection-timeout seconds. @@ -738,7 +764,7 @@ command whose response triggered the error." (nnheader-fold-continuation-lines) ;; Remove all "\r"'s. (nnheader-strip-cr) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'headers))))) (deffoo nntp-retrieve-groups (groups &optional server) @@ -820,7 +846,8 @@ command whose response triggered the error." (if (not nntp-server-list-active-group) (progn - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (nntp-copy-to-buffer nntp-server-buffer + (point-min) (point-max)) 'group) ;; We have read active entries, so we just delete the ;; superfluous gunk. @@ -828,7 +855,7 @@ command whose response triggered the error." (while (re-search-forward "^[.2-5]" nil t) (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'active))))))) (deffoo nntp-retrieve-articles (articles &optional group server) @@ -893,7 +920,7 @@ command whose response triggered the error." (narrow-to-region (setq point (goto-char (point-max))) (progn - (insert-buffer-substring buf last-point (cdr entry)) + (nntp-insert-buffer-substring buf last-point (cdr entry)) (point-max))) (setq last-point (cdr entry)) (nntp-decode-text) @@ -1206,7 +1233,7 @@ password contained in '~/.nntp-authinfo'." (format " *server %s %s %s*" nntp-address nntp-port-number (gnus-buffer-exists-p buffer)))) - (mm-enable-multibyte) + (mm-disable-multibyte) (set (make-local-variable 'after-change-functions) nil) (set (make-local-variable 'nntp-process-wait-for) nil) (set (make-local-variable 'nntp-process-callback) nil) @@ -1390,7 +1417,7 @@ password contained in '~/.nntp-authinfo'." (goto-char (point-max)) (save-restriction (narrow-to-region (point) (point)) - (insert-buffer-substring buf start) + (nntp-insert-buffer-substring buf start) (when decode (nntp-decode-text)))))) ;; report it. @@ -1619,7 +1646,7 @@ password contained in '~/.nntp-authinfo'." (when in-process-buffer-p (set-buffer buf) (goto-char (point-max)) - (insert-buffer-substring process-buffer) + (nntp-insert-buffer-substring process-buffer) (set-buffer process-buffer) (erase-buffer) (set-buffer buf)) diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index c8e309d8c14..d152c2480ad 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -36,6 +36,7 @@ ;;; Code: (require 'mail-utils) +(defvar parse-time-months) (defgroup pop3 nil "Post Office Protocol." @@ -241,16 +242,23 @@ Returns the process associated with the connection." mailhost port))) (when process ;; There's a load of info printed that needs deleting. - (while (when (memq (process-status process) '(open run)) - (pop3-accept-process-output process) - (goto-char (point-max)) - (forward-line -1) - (if (looking-at "\\+OK") - (progn - (delete-region (point-min) (point)) - nil) + (let ((again 't)) + ;; repeat until + ;; - either we received the +OK line + ;; - or accept-process-output timed out without getting + ;; anything + (while (and again + (setq again (memq (process-status process) + '(open run)))) + (setq again (pop3-accept-process-output process)) + (goto-char (point-max)) + (forward-line -1) + (cond ((looking-at "\\+OK") + (setq again nil) + (delete-region (point-min) (point))) + ((not again) (pop3-quit process) - (error "POP SSL connexion failed")))) + (error "POP SSL connexion failed"))))) process))) ((eq pop3-stream-type 'starttls) ;; gnutls-cli, openssl don't accept service names @@ -327,8 +335,6 @@ Return the response string if optional second argument is non-nil." (forward-char))) (set-marker end nil)) -(eval-when-compile (defvar parse-time-months)) - ;; Copied from message-make-date. (defun pop3-make-date (&optional now) "Make a valid date header. diff --git a/lisp/gnus/qp.el b/lisp/gnus/qp.el index 5689a70f3ac..8ae34f193a1 100644 --- a/lisp/gnus/qp.el +++ b/lisp/gnus/qp.el @@ -31,7 +31,7 @@ ;;; Code: (require 'mm-util) -(eval-when-compile (defvar mm-use-ultra-safe-encoding)) +(defvar mm-use-ultra-safe-encoding) ;;;###autoload (defun quoted-printable-decode-region (from to &optional coding-system) diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el index b789061853f..aa9999a7722 100644 --- a/lisp/gnus/rfc2047.el +++ b/lisp/gnus/rfc2047.el @@ -30,8 +30,8 @@ ;;; Code: (eval-when-compile - (require 'cl) - (defvar message-posting-charset)) + (require 'cl)) +(defvar message-posting-charset) (require 'qp) (require 'mm-util) @@ -101,6 +101,40 @@ quoted-printable and base64 respectively.") (defvar rfc2047-encode-encoded-words t "Whether encoded words should be encoded again.") +(defvar rfc2047-allow-irregular-q-encoded-words t + "*Whether to decode irregular Q-encoded words.") + +(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'. + (defconst rfc2047-encoded-word-regexp + "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?[ ->@-~]*\ +\\)\\?=" + "Regexp that matches encoded word." + ;; The patterns for the B encoding and the Q encoding, i.e. the ones + ;; beginning with "B" and "Q" respectively, are restricted into only + ;; the characters that those encodings may generally use. + ) + (defconst rfc2047-encoded-word-regexp-loose + "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\ +\\)\\?=" + "Regexp that matches encoded word allowing loose Q encoding." + ;; The pattern for the Q encoding, i.e. the one beginning with "Q", + ;; is similar to: + ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*" + ;; <--------1-------><----------2,3----------><--4--><-5-> + ;; They mean: + ;; 1. After "Q?", allow "?"s that follow a character other than "=". + ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator. + ;; 3. In the middle of an encoded word, allow "?"s that follow a + ;; character other than "=". + ;; 4. Allow any characters other than "?" in the middle of an + ;; encoded word. + ;; 5. At the end, allow "?"s. + )) + ;;; ;;; Functions for encoding RFC2047 messages ;;; @@ -287,7 +321,6 @@ Should be called narrowed to the head of the message." ;; Fixme: This, and the require below may not be the Right Thing, but ;; should be safe just before release. -- fx 2001-02-08 -(eval-when-compile (defvar message-posting-charset)) (defun rfc2047-encodable-p () "Return non-nil if any characters in current buffer need encoding in headers. @@ -298,7 +331,7 @@ The buffer may be narrowed." (goto-char (point-min)) (or (and rfc2047-encode-encoded-words (prog1 - (search-forward "=?" nil t) + (re-search-forward rfc2047-encoded-word-regexp nil t) (goto-char (point-min)))) (and charsets (not (equal charsets (list (car message-posting-charset)))))))) @@ -533,10 +566,19 @@ By default, the string is treated as containing addresses (see (rfc2047-encode-region (point-min) (point-max)) (buffer-string))) +;; From RFC 2047: +;; 2. Syntax of encoded-words +;; [...] +;; While there is no limit to the length of a multiple-line header +;; field, each line of a header field that contains one or more +;; 'encoded-word's is limited to 76 characters. +;; +;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it. (defvar rfc2047-encode-max-chars 76 "Maximum characters of each header line that contain encoded-words. -If it is nil, encoded-words will not be folded. Too small value may -cause an error. Don't change this for no particular reason.") +According to RFC 2047, it is 76. If it is nil, encoded-words +will not be folded. Too small value may cause an error. You +should not change this value.") (defun rfc2047-encode-1 (column string cs encoder start crest tail &optional eword) @@ -827,11 +869,6 @@ it, put the following line in your ~/.gnus.el file: ;;; Functions for decoding RFC2047 messages ;;; -(eval-and-compile - (defconst rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\ -\\?\\(B\\|Q\\)\\?\\([!->@-~ ]*\\)\\?=")) - (defvar rfc2047-quote-decoded-words-containing-tspecials nil "If non-nil, quote decoded words containing special characters.") @@ -950,10 +987,12 @@ If ADDRESS-MIME is non-nil, strip backslashes which precede characters other than `\"' and `\\' in quoted strings." (interactive "r") (let ((case-fold-search t) - (eword-regexp (eval-when-compile - ;; Ignore whitespace between encoded-words. - (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp - "\\)"))) + (eword-regexp + (if rfc2047-allow-irregular-q-encoded-words + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)")) + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)")))) b e match words) (save-excursion (save-restriction @@ -969,7 +1008,7 @@ other than `\"' and `\\' in quoted strings." (while match (push (list (match-string 2) ;; charset (char-after (match-beginning 3)) ;; encoding - (match-string 4) ;; encoded-text + (substring (match-string 3) 2) ;; encoded-text (match-string 1)) ;; encoded-word words) ;; Look for the subsequent encoded-words. diff --git a/lisp/gnus/sieve-manage.el b/lisp/gnus/sieve-manage.el index d8bd965718d..5cf14f7eb32 100644 --- a/lisp/gnus/sieve-manage.el +++ b/lisp/gnus/sieve-manage.el @@ -76,7 +76,8 @@ ;;; Code: -(require 'password) +(or (require 'password-cache nil t) + (require 'password)) (eval-when-compile (require 'sasl) (require 'starttls)) diff --git a/lisp/gnus/smime-ldap.el b/lisp/gnus/smime-ldap.el deleted file mode 100644 index 882f9f80c6f..00000000000 --- a/lisp/gnus/smime-ldap.el +++ /dev/null @@ -1,206 +0,0 @@ -;;; smime-ldap.el --- client interface to LDAP for Emacs - -;; Copyright (C) 1998, 1999, 2000, 2005 Free Software Foundation, Inc. - -;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch> -;; Maintainer: Arne J,Ax(Brgensen <arne@arnested.dk> -;; Created: February 2005 -;; Keywords: comm - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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 3, or (at your option) -;; any later version. - -;; GNU Emacs 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. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This file has a slightly changed implementation of Emacs 21.3's -;; ldap-search and ldap-search-internal from ldap.el. The changes are -;; made to achieve compatibility with OpenLDAP v2 and to make it -;; possible to retrieve LDAP attributes that are tagged ie ";binary". - -;; The file also adds a compatibility layer for Emacs and XEmacs. - -;;; Code: - -(require 'ldap) - -(defun smime-ldap-search (filter &optional host attributes attrsonly withdn) - "Perform an LDAP search. -FILTER is the search filter in RFC1558 syntax. -HOST is the LDAP host on which to perform the search. -ATTRIBUTES are the specific attributes to retrieve, nil means -retrieve all. -ATTRSONLY, if non-nil, retrieves the attributes only, without -the associated values. -If WITHDN is non-nil, each entry in the result will be prepended with -its distinguished name WITHDN. -Additional search parameters can be specified through -`ldap-host-parameters-alist', which see." - (interactive "sFilter:") - ;; for XEmacs - (if (fboundp 'ldap-search-entries) - (ldap-search-entries filter host attributes attrsonly) - ;; for Emacs 22 - (if (>= emacs-major-version 22) - (cdr (ldap-search filter host attributes attrsonly)) - ;; for Emacs 21.x - (or host - (setq host ldap-default-host) - (error "No LDAP host specified")) - (let ((host-plist (cdr (assoc host ldap-host-parameters-alist))) - result) - (setq result (smime-ldap-search-internal - (append host-plist - (list 'host host - 'filter filter - 'attributes attributes - 'attrsonly attrsonly - 'withdn withdn)))) - (cdr (if ldap-ignore-attribute-codings - result - (mapcar (function - (lambda (record) - (mapcar 'ldap-decode-attribute record))) - result))))))) - -(defun smime-ldap-search-internal (search-plist) - "Perform a search on a LDAP server. -SEARCH-PLIST is a property list describing the search request. -Valid keys in that list are: -`host' is a string naming one or more (blank-separated) LDAP servers to -to try to connect to. Each host name may optionally be of the form HOST:PORT. -`filter' is a filter string for the search as described in RFC 1558. -`attributes' is a list of strings indicating which attributes to retrieve -for each matching entry. If nil, return all available attributes. -`attrsonly', if non-nil, indicates that only attributes are retrieved, -not their associated values. -`base' is the base for the search as described in RFC 1779. -`scope' is one of the three symbols `sub', `base' or `one'. -`binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax). -`passwd' is the password to use for simple authentication. -`deref' is one of the symbols `never', `always', `search' or `find'. -`timelimit' is the timeout limit for the connection in seconds. -`sizelimit' is the maximum number of matches to return. -`withdn' if non-nil each entry in the result will be prepended with -its distinguished name DN. -The function returns a list of matching entries. Each entry is itself -an alist of attribute/value pairs." - (let ((buf (get-buffer-create " *ldap-search*")) - (bufval (get-buffer-create " *ldap-value*")) - (host (or (plist-get search-plist 'host) - ldap-default-host)) - (filter (plist-get search-plist 'filter)) - (attributes (plist-get search-plist 'attributes)) - (attrsonly (plist-get search-plist 'attrsonly)) - (base (or (plist-get search-plist 'base) - ldap-default-base)) - (scope (plist-get search-plist 'scope)) - (binddn (plist-get search-plist 'binddn)) - (passwd (plist-get search-plist 'passwd)) - (deref (plist-get search-plist 'deref)) - (timelimit (plist-get search-plist 'timelimit)) - (sizelimit (plist-get search-plist 'sizelimit)) - (withdn (plist-get search-plist 'withdn)) - (numres 0) - arglist dn name value record result) - (if (or (null filter) - (equal "" filter)) - (error "No search filter")) - (setq filter (cons filter attributes)) - (save-excursion - (set-buffer buf) - (erase-buffer) - (if (and host - (not (equal "" host))) - (setq arglist (nconc arglist (list (format "-h%s" host))))) - (if (and attrsonly - (not (equal "" attrsonly))) - (setq arglist (nconc arglist (list "-A")))) - (if (and base - (not (equal "" base))) - (setq arglist (nconc arglist (list (format "-b%s" base))))) - (if (and scope - (not (equal "" scope))) - (setq arglist (nconc arglist (list (format "-s%s" scope))))) - (if (and binddn - (not (equal "" binddn))) - (setq arglist (nconc arglist (list (format "-D%s" binddn))))) - (if (and passwd - (not (equal "" passwd))) - (setq arglist (nconc arglist (list (format "-w%s" passwd))))) - (if (and deref - (not (equal "" deref))) - (setq arglist (nconc arglist (list (format "-a%s" deref))))) - (if (and timelimit - (not (equal "" timelimit))) - (setq arglist (nconc arglist (list (format "-l%s" timelimit))))) - (if (and sizelimit - (not (equal "" sizelimit))) - (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) - (eval `(call-process ldap-ldapsearch-prog - nil - buf - nil - ,@arglist - "-tt" ; Write values to temp files - "-x" - "-LL" - ; ,@ldap-ldapsearch-args - ,@filter)) - (insert "\n") - (goto-char (point-min)) - - (while (re-search-forward "[\t\n\f]+ " nil t) - (replace-match "" nil nil)) - (goto-char (point-min)) - - (if (looking-at "usage") - (error "Incorrect ldapsearch invocation") - (message "Parsing results... ") - (while (progn - (skip-chars-forward " \t\n") - (not (eobp))) - (setq dn (buffer-substring (point) (save-excursion - (end-of-line) - (point)))) - (forward-line 1) - (while (looking-at (concat "^\\(\\w*\\)\\(;\\w*\\)?[=:\t ]+" - "\\(<[\t ]*file://\\)?\\(.*\\)$")) - (setq name (match-string 1) - value (match-string 4)) - (save-excursion - (set-buffer bufval) - (erase-buffer) - (insert-file-contents-literally value) - (delete-file value) - (setq value (buffer-substring (point-min) (point-max)))) - (setq record (cons (list name value) - record)) - (forward-line 1)) - (setq result (cons (if withdn - (cons dn (nreverse record)) - (nreverse record)) result)) - (setq record nil) - (skip-chars-forward " \t\n") - (message "Parsing results... %d" numres) - (1+ numres)) - (message "Parsing results... done") - (nreverse result))))) - -(provide 'smime-ldap) - -;; arch-tag: 87e6bc44-21fc-4e9b-a89b-f55f031f78f8 -;;; smime-ldap.el ends here diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index ee62fd8124b..31545c16044 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -122,8 +122,8 @@ ;;; Code: (require 'dig) -(require 'smime-ldap) -(require 'password) +(or (require 'password-cache nil t) + (require 'password)) (eval-when-compile (require 'cl)) (eval-and-compile @@ -424,8 +424,7 @@ Any details (stdout and stderr) are left in the buffer specified by (insert-buffer-substring smime-details-buffer) nil)) -(eval-when-compile - (defvar from)) +(defvar from) (defun smime-decrypt-region (b e keyfile) "Decrypt S/MIME message in region between B and E with key in KEYFILE. @@ -590,8 +589,17 @@ A string or a list of strings is returned." (defun smime-cert-by-ldap-1 (mail host) "Get cetificate for MAIL from the ldap server at HOST." - (let ((ldapresult (smime-ldap-search (concat "mail=" mail) - host '("userCertificate") nil)) + (let ((ldapresult + (funcall + (if (or (featurep 'xemacs) + ;; For Emacs >= 22 we don't need smime-ldap.el + (< emacs-major-version 22)) + (progn + (require 'smime-ldap) + 'smime-ldap-search) + 'ldap-search) + (concat "mail=" mail) + host '("userCertificate") nil)) (retbuf (generate-new-buffer (format "*certificate for %s*" mail))) cert) (if (and (>= (length ldapresult) 1) diff --git a/lisp/gnus/spam-wash.el b/lisp/gnus/spam-wash.el index d1be1816a4f..be9a822dd2f 100644 --- a/lisp/gnus/spam-wash.el +++ b/lisp/gnus/spam-wash.el @@ -1,21 +1,21 @@ ;;; spam-wash.el --- wash spam before analysis -;; Copyright (C) 2004 Free Software Foundation, Inc. +;; Copyright (C) 2004, 2007 Free Software Foundation, Inc. ;; Author: Andrew Cohen <cohen@andy.bu.edu> ;; Keywords: mail ;; This file is part of GNU Emacs. -;; This is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by +;; GNU Emacs 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 3, or (at your option) ;; any later version. -;; This 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. +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 4164d3f718b..fddebb1d290 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -81,7 +81,7 @@ ;;{{{ Main parameters. (defvar spam-backends nil "List of spam.el backends with all the pertinent data. -Populated by spam-install-backend-super.") +Populated by `spam-install-backend-super'.") (defgroup spam nil "Spam configuration." @@ -91,13 +91,13 @@ Populated by spam-install-backend-super.") (defcustom spam-summary-exit-behavior 'default "Exit behavior at the time of summary exit. -Note that setting the spam-use-move or spam-use-copy backends on +Note that setting the `spam-use-move' or `spam-use-copy' backends on a group through group/topic parameters overrides this mechanism." - :type '(choice (const 'default :tag + :type '(choice (const 'default :tag "Move spam out of all groups. Move ham out of spam groups.") - (const 'move-all :tag + (const 'move-all :tag "Move spam out of all groups. Move ham out of all groups.") - (const 'move-none :tag + (const 'move-none :tag "Never move spam or ham out of any groups.")) :group 'spam) @@ -124,8 +124,7 @@ a group through group/topic parameters overrides this mechanism." (defcustom spam-split-symbolic-return-positive nil "Whether `spam-split' should ALWAYS work with symbols or group names. -Do not set this if you use `spam-split' in a fancy split - method." +Do not set this if you use `spam-split' in a fancy split method." :type 'boolean :group 'spam) @@ -139,7 +138,7 @@ without losing it to the automatic spam-marking process." (defcustom spam-mark-ham-unread-before-move-from-spam-group nil "Whether ham should be marked unread before it's moved. -The article is moved out of a spam group according to ham-process-destination. +The article is moved out of a spam group according to `ham-process-destination'. This variable is an official entry in the international Longest Variable Name Competition." :type 'boolean @@ -403,7 +402,7 @@ Only meaningful if you enable `spam-use-regex-body'." :group 'spam) (defcustom spam-summary-score-preferred-header nil - "Preferred header to use for spam-summary-score." + "Preferred header to use for `spam-summary-score'." :type '(choice :tag "Header name" (symbol :tag "SpamAssassin etc" X-Spam-Status) (symbol :tag "Bogofilter" X-Bogosity) @@ -621,17 +620,17 @@ order for SpamAssassin to recognize the new registered spam." :group 'spam-spamassassin) (defcustom spam-sa-learn-spam-switch "--spam" - "The switch that sa-learn uses to register spam messages" + "The switch that sa-learn uses to register spam messages." :type 'string :group 'spam-spamassassin) (defcustom spam-sa-learn-ham-switch "--ham" - "The switch that sa-learn uses to register ham messages" + "The switch that sa-learn uses to register ham messages." :type 'string :group 'spam-spamassassin) (defcustom spam-sa-learn-unregister-switch "--forget" - "The switch that sa-learn uses to unregister messages messages" + "The switch that sa-learn uses to unregister messages messages." :type 'string :group 'spam-spamassassin) @@ -722,7 +721,7 @@ finds ham or spam.") ;;{{{ convenience functions (defun spam-clear-cache (symbol) - "Clear the spam-caches entry for a check." + "Clear the `spam-caches' entry for a check." (remhash symbol spam-caches)) (defun spam-xor (a b) @@ -730,7 +729,7 @@ finds ham or spam.") (and (or a b) (not (and a b)))) (defun spam-set-difference (list1 list2) - "Return a set difference of LIST1 and LIST2. + "Return a set difference of LIST1 and LIST2. When either list is nil, the other is returned." (if (and list1 list2) ;; we have two non-nil lists @@ -837,15 +836,14 @@ Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF, and an indication whether the backend is STATISTICAL." - (setq spam-backends (add-to-list 'spam-backends backend)) (while properties (let ((property (pop properties)) (value (pop properties))) (if (spam-backend-property-valid-p property) (put backend property value) - (gnus-error - 5 + (gnus-error + 5 "spam-install-backend-super got an invalid property %s" property))))) @@ -875,7 +873,7 @@ The value nil means that the check does not yield a decision, and so, that further checks are needed. The value t means that the message is definitely not spam, and that further spam checks should be inhibited. Otherwise, a mailgroup name or the symbol -'spam (depending on spam-split-symbolic-return) is returned where +'spam (depending on `spam-split-symbolic-return') is returned where the mail should go, and further checks are also inhibited. The usual mailgroup name is the value of `spam-split-group', meaning that the message is definitely a spam." @@ -892,7 +890,7 @@ that the message is definitely a spam." (setq info (format "Backend %s has the following properties:\n" backend)) (dolist (property (spam-backend-properties)) - (setq info (format "%s%s=%s\n" + (setq info (format "%s%s=%s\n" info property (get backend property)))) @@ -907,13 +905,13 @@ CLASSIFICATION is 'ham or 'spam." (if (and (spam-classification-valid-p classification) (spam-backend-function-type-valid-p type)) - (let ((retrieval - (intern + (let ((retrieval + (intern (format "spam-backend-%s-%s-function" classification type)))) (funcall retrieval backend)) - (gnus-error + (gnus-error 5 "%s was passed invalid backend %s, classification %s, or type %s" "spam-backend-function" @@ -921,21 +919,21 @@ CLASSIFICATION is 'ham or 'spam." classification type))) -(defun spam-backend-article-list-property (classification +(defun spam-backend-article-list-property (classification &optional unregister) "Property name of article list with CLASSIFICATION and UNREGISTER." (let* ((r (if unregister "unregister" "register")) (prop (format "%s-%s" classification r))) prop)) -(defun spam-backend-get-article-todo-list (backend - classification +(defun spam-backend-get-article-todo-list (backend + classification &optional unregister) - "Get the articles to be processed for BACKEND and CLASSIFICATION. + "Get the articles to be processed for BACKEND and CLASSIFICATION. With UNREGISTER, get articles to be unregistered. This is a temporary storage function - nothing here persists." (get - backend + backend (intern (spam-backend-article-list-property classification unregister)))) (defun spam-backend-put-article-todo-list (backend classification list &optional unregister) @@ -977,7 +975,7 @@ The previous backend settings for ALIAS are erased." ;; install alias with no properties at first (spam-install-backend-super alias) - + (dolist (property (spam-backend-properties)) (put alias property (get backend property)))) @@ -991,8 +989,8 @@ Accepts ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend has no incoming check and can't be statistical." - (spam-install-backend-super - backend + (spam-install-backend-super + backend 'hrf hrf 'srf srf 'huf huf 'suf suf 'mover t)) (defun spam-install-nocheck-backend (backend hrf srf huf suf) @@ -1001,7 +999,7 @@ Accepts ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend has no incoming check and can't be statistical (it could be, but in practice that doesn't happen)." - (spam-install-backend-super + (spam-install-backend-super backend 'hrf hrf 'srf srf 'huf huf 'suf suf)) @@ -1010,8 +1008,8 @@ statistical (it could be, but in practice that doesn't happen)." Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend won't be -statistical (use spam-install-statistical-backend for that)." - (spam-install-backend-super +statistical (use `spam-install-statistical-backend' for that)." + (spam-install-backend-super backend 'check check 'hrf hrf 'srf srf 'huf huf 'suf suf)) @@ -1020,15 +1018,15 @@ statistical (use spam-install-statistical-backend for that)." Accepts incoming CHECK, ham registration function HRF, spam registration function SRF, ham unregistration function HUF, spam unregistration function SUF. The backend will be -statistical (use spam-install-backend for non-statistical +statistical (use `spam-install-backend' for non-statistical backends)." - (spam-install-backend-super + (spam-install-backend-super backend 'check check 'statistical t 'hrf hrf 'srf srf 'huf huf 'suf suf)) (defun spam-install-statistical-checkonly-backend (backend check) "Install a statistical BACKEND than can only CHECK for spam." - (spam-install-backend-super + (spam-install-backend-super backend 'check check 'statistical t)) @@ -1084,7 +1082,7 @@ backends)." nil nil) -(spam-install-backend 'spam-use-BBDB +(spam-install-backend 'spam-use-BBDB 'spam-check-BBDB 'spam-BBDB-register-routine nil @@ -1128,7 +1126,7 @@ backends)." 'spam-stat-unregister-ham-routine 'spam-stat-unregister-spam-routine) -(spam-install-statistical-backend 'spam-use-spamassassin +(spam-install-statistical-backend 'spam-use-spamassassin 'spam-check-spamassassin 'spam-spamassassin-register-ham-routine 'spam-spamassassin-register-spam-routine @@ -1224,13 +1222,13 @@ Note this has to be fast." With SPECIFIC-HEADER, returns only that header's score. Will not return a nil score." (let (score) - (dolist (header + (dolist (header (if specific-header (list specific-header) (spam-necessary-extra-headers))) - (setq score + (setq score (spam-extra-header-to-number header headers)) - (when score + (when score (return))) (or score 0))) @@ -1258,7 +1256,7 @@ Will not return a nil score." (let (found) (dolist (backend (spam-backend-list)) (when (and (spam-backend-statistical-p backend) - (or (symbol-value backend) + (or (symbol-value backend) (memq backend force-symbols))) (setq found backend))) found)) @@ -1287,14 +1285,14 @@ This list contains pairs associating the obsolete ham/spam exit processor variables with a classification and a spam-use-* variable. When the processor variable is nil, just the classification and spam-use-* check variable are used. This is -superceded by the new spam backend code, so it's only consulted +superseded by the new spam backend code, so it's only consulted for backwards compatibility.") (defun spam-group-processor-p (group backend &optional classification) "Checks if GROUP has a BACKEND with CLASSIFICATION registered. Also accepts the obsolete processors, which can be found in gnus.el and in spam-list-of-processors. In the case of mover -backends, checks the setting of spam-summary-exit-behavior in +backends, checks the setting of `spam-summary-exit-behavior' in addition to the set values for the group." (if (and (stringp group) (symbolp backend)) @@ -1315,7 +1313,7 @@ addition to the set values for the group." ;; spam-summary-exit-behavior-logic for mover backends (unless found (when (spam-backend-mover-p backend) - (setq + (setq found (cond ((eq spam-summary-exit-behavior 'move-all) t) @@ -1325,7 +1323,7 @@ addition to the set values for the group." ;; move ham out of spam groups (and (eq classification 'ham) (spam-group-spam-contents-p group)))) - (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" + (t (gnus-error 5 "Unknown spam-summary-exit-behavior: %s" spam-summary-exit-behavior)))))) found)) @@ -1385,8 +1383,8 @@ addition to the set values for the group." ;; call spam-register-routine with specific articles to unregister, ;; when there are articles to unregister and the check is enabled (when (and unregister-list (symbol-value backend)) - (spam-backend-put-article-todo-list backend - classification + (spam-backend-put-article-todo-list backend + classification unregister-list t)))))) @@ -1398,7 +1396,7 @@ addition to the set values for the group." gnus-newsgroup-name backend classification) - (spam-backend-put-article-todo-list backend + (spam-backend-put-article-todo-list backend classification (spam-list-articles gnus-newsgroup-articles @@ -1457,11 +1455,11 @@ addition to the set values for the group." article) (gnus-summary-mark-article article gnus-expirable-mark)) (gnus-summary-set-process-mark article) - + (if respool ; respooling is with a "fake" group (let ((spam-split-disabled (or spam-split-disabled - (and (eq classification 'ham) + (and (eq classification 'ham) spam-disable-spam-split-during-ham-respool)))) (gnus-message 9 "Respooling article %d with method %s" article respool-method) @@ -1476,7 +1474,7 @@ addition to the set values for the group." (gnus-message 9 "Moving article %d to group %s" article group) (gnus-summary-move-article nil group))))) ; else move articles - + ;; now delete the articles, unless a) copy is t, and there was a copy done ;; b) a move was done to a single group ;; c) backend-supports-deletions is nil @@ -1488,33 +1486,33 @@ addition to the set values for the group." (when articles (let ((gnus-novice-user nil)) ; don't ask me if I'm sure (gnus-summary-delete-article nil))))) - + (gnus-summary-yank-process-mark) (length articles)))) (defun spam-copy-spam-routine (articles) - (spam-copy-or-move-routine - t + (spam-copy-or-move-routine + t (gnus-parameter-spam-process-destination gnus-newsgroup-name) articles 'spam)) (defun spam-move-spam-routine (articles) - (spam-copy-or-move-routine + (spam-copy-or-move-routine nil (gnus-parameter-spam-process-destination gnus-newsgroup-name) articles 'spam)) (defun spam-copy-ham-routine (articles) - (spam-copy-or-move-routine - t + (spam-copy-or-move-routine + t (gnus-parameter-ham-process-destination gnus-newsgroup-name) articles 'ham)) (defun spam-move-ham-routine (articles) - (spam-copy-or-move-routine + (spam-copy-or-move-routine nil (gnus-parameter-ham-process-destination gnus-newsgroup-name) articles @@ -1570,9 +1568,9 @@ to find it out)." ((equal field 'extra) (mail-header-extra data-header)) (t - (gnus-error - 5 - "spam-fetch-field-fast: unknown field %s requested" + (gnus-error + 5 + "spam-fetch-field-fast: unknown field %s requested" field) nil)) (gnus-message 6 "Article %d has a nil data header" article))))) @@ -1621,7 +1619,7 @@ to find it out)." This function can be used as an entry in the variable `nnmail-split-fancy', for example like this: (: spam-split). It can take checks as parameters. A string as a parameter will set the -spam-split-group to that string. +`spam-split-group' to that string. See the Info node `(gnus)Fancy Mail Splitting' for more details." (interactive) @@ -1673,7 +1671,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." decision)))))))) (defun spam-find-spam () - "This function will detect spam in the current newsgroup using spam-split." + "Detect spam in the current newsgroup using `spam-split'." (interactive) (let* ((group gnus-newsgroup-name) @@ -1685,7 +1683,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." gnus-newsgroup-unseen)) article-cannot-be-faked) - + (dolist (backend methods) (when (spam-backend-statistical-p backend) (setq article-cannot-be-faked t) @@ -1702,10 +1700,10 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (subject (spam-fetch-field-subject-fast article)) (sender (spam-fetch-field-from-fast article)) registry-lookup) - + (unless id (gnus-message 6 "Article %d has no message ID!" article)) - + (when (and id spam-log-to-registry) (setq registry-lookup (spam-log-registration-type id 'incoming)) (when registry-lookup @@ -1732,12 +1730,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (apply 'spam-split methods)))))) (if (equal split-return 'spam) (gnus-summary-mark-article article gnus-spam-mark)) - + (when (and id split-return spam-log-to-registry) (when (zerop (gnus-registry-group-count id)) (gnus-registry-add-group id group subject sender)) - + (unless registry-lookup (spam-log-processing-to-registry id @@ -1763,11 +1761,11 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (delcount 0)) ;; clear the old lists right away - (spam-backend-put-article-todo-list backend + (spam-backend-put-article-todo-list backend classification nil nil) - (spam-backend-put-article-todo-list backend + (spam-backend-put-article-todo-list backend classification nil t) @@ -1778,29 +1776,29 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (incf delcount) (setq rlist (delq article rlist)) (setq ulist (delq article ulist)))) - + (unless (zerop delcount) - (gnus-message - 9 + (gnus-message + 9 "%d messages were saved the trouble of unregistering and then registering" delcount)) - + ;; unregister articles (unless (zerop (length ulist)) (let ((num (spam-unregister-routine classification backend ulist))) (when (> num 0) - (gnus-message + (gnus-message 6 "%d %s messages were unregistered by backend %s." num classification backend)))) - + ;; register articles (unless (zerop (length rlist)) (let ((num (spam-register-routine classification backend rlist))) (when (> num 0) - (gnus-message + (gnus-message 6 "%d %s messages were registered by backend %s." num @@ -1808,12 +1806,12 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." backend))))))))) (defun spam-unregister-routine (classification - backend + backend specific-articles) (spam-register-routine classification backend specific-articles t)) (defun spam-register-routine (classification - backend + backend specific-articles &optional unregister) (when (and (spam-classification-valid-p classification) @@ -2134,7 +2132,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (save-excursion (save-window-excursion (bbdb-records nil t) - (mapatoms + (mapatoms (lambda (symbol) (intern (downcase (symbol-name symbol)) bbdb-cache)) bbdb-hashtable)))) @@ -2311,8 +2309,8 @@ With a non-nil REMOVE, remove them." (defun spam-enter-list (addresses file &optional remove) "Enter ADDRESSES into the given FILE. -Either the whitelist or the blacklist files can be used. With -REMOVE not nil, remove the ADDRESSES." +Either the whitelist or the blacklist files can be used. +With a non-nil REMOVE, remove the ADDRESSES." (if (stringp addresses) (spam-enter-list (list addresses) file remove) ;; else, we have a list of addresses here @@ -2467,7 +2465,7 @@ REMOVE not nil, remove the ADDRESSES." (spam-report-resend-register-routine articles t)) (defun spam-report-resend-register-routine (articles &optional ham) - (let* ((resend-to-gp + (let* ((resend-to-gp (if ham (gnus-parameter-ham-resend-to gnus-newsgroup-name) (gnus-parameter-spam-resend-to gnus-newsgroup-name))) @@ -2492,7 +2490,7 @@ REMOVE not nil, remove the ADDRESSES." ;; return something sensible if the score can't be determined (defun spam-bogofilter-score (&optional recheck) - "Get the Bogofilter spamicity score" + "Get the Bogofilter spamicity score." (interactive "P") (save-window-excursion (gnus-summary-show-article t) @@ -2509,10 +2507,10 @@ REMOVE not nil, remove the ADDRESSES." (when (eq spam-bogofilter-valid 'unknown) (setq spam-bogofilter-valid (not (string-match "^bogofilter version 0\\.\\([0-9]\\|1[01]\\)\\." - (shell-command-to-string + (shell-command-to-string (format "%s -V" spam-bogofilter-program)))))) spam-bogofilter-valid) - + (defun spam-check-bogofilter (&optional score) "Check the Bogofilter backend for the classification of this message." (if (spam-verify-bogofilter) @@ -2550,7 +2548,7 @@ REMOVE not nil, remove the ADDRESSES." (when (stringp article-string) (with-temp-buffer (insert article-string) - + (apply 'call-process-region (point-min) (point-max) spam-bogofilter-program @@ -2736,7 +2734,7 @@ REMOVE not nil, remove the ADDRESSES." ;; return something sensible if the score can't be determined (defun spam-bsfilter-score (&optional recheck) - "Get the Bsfilter spamicity score" + "Get the Bsfilter spamicity score." (interactive "P") (save-window-excursion (gnus-summary-show-article t) @@ -2749,7 +2747,7 @@ REMOVE not nil, remove the ADDRESSES." (or score "0")))) (defun spam-check-bsfilter (&optional score) - "Check the Bsfilter backend for the classification of this message" + "Check the Bsfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) (dir spam-bsfilter-database-directory) return) @@ -2823,7 +2821,7 @@ REMOVE not nil, remove the ADDRESSES." ;; return something sensible if the score can't be determined (defun spam-crm114-score () - "Get the CRM114 Mailfilter pR" + "Get the CRM114 Mailfilter pR." (interactive) (save-window-excursion (gnus-summary-show-article t) @@ -2835,7 +2833,7 @@ REMOVE not nil, remove the ADDRESSES." (or score "0")))) (defun spam-check-crm114 (&optional score) - "Check the CRM114 Mailfilter backend for the classification of this message" + "Check the CRM114 Mailfilter backend for the classification of this message." (let ((article-buffer-name (buffer-name)) (db spam-crm114-database-directory) return) @@ -2897,9 +2895,9 @@ REMOVE not nil, remove the ADDRESSES." (defun spam-initialize (&rest symbols) "Install the spam.el hooks and do other initialization. When SYMBOLS is given, set those variables to t. This is so you -can call spam-initialize before you set spam-use-* variables on +can call `spam-initialize' before you set spam-use-* variables on explicitly, and matters only if you need the extra headers -installed through spam-necessary-extra-headers." +installed through `spam-necessary-extra-headers'." (interactive) (dolist (var symbols) @@ -2923,7 +2921,7 @@ installed through spam-necessary-extra-headers." (add-hook 'gnus-summary-prepared-hook 'spam-find-spam)) (defun spam-unload-hook () - "Uninstall the spam.el hooks" + "Uninstall the spam.el hooks." (interactive) (remove-hook 'gnus-save-newsrc-hook 'spam-maybe-spam-stat-save) (remove-hook 'gnus-get-top-new-news-hook 'spam-maybe-spam-stat-load) diff --git a/lisp/gnus/utf7.el b/lisp/gnus/utf7.el index dbe749cad69..deba6d131e4 100644 --- a/lisp/gnus/utf7.el +++ b/lisp/gnus/utf7.el @@ -209,20 +209,26 @@ Characters are in raw byte pairs in narrowed buffer." (defun utf7-encode (string &optional for-imap) "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." - (let ((default-enable-multibyte-characters t)) - (with-temp-buffer - (insert string) - (utf7-encode-internal for-imap) - (buffer-string)))) + (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) + ;; Emacs 23 with proper support for IMAP + (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) + (let ((default-enable-multibyte-characters t)) + (with-temp-buffer + (insert string) + (utf7-encode-internal for-imap) + (buffer-string))))) (defun utf7-decode (string &optional for-imap) "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." - (let ((default-enable-multibyte-characters nil)) - (with-temp-buffer - (insert string) - (utf7-decode-internal for-imap) - (mm-enable-multibyte) - (buffer-string)))) + (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) + ;; Emacs 23 with proper support for IMAP + (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) + (let ((default-enable-multibyte-characters nil)) + (with-temp-buffer + (insert string) + (utf7-decode-internal for-imap) + (mm-enable-multibyte) + (buffer-string))))) (provide 'utf7) diff --git a/lisp/gnus/yenc.el b/lisp/gnus/yenc.el index 7550186b35e..7843f6a9aa0 100644 --- a/lisp/gnus/yenc.el +++ b/lisp/gnus/yenc.el @@ -55,6 +55,25 @@ 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213]) +(defun yenc-first-part-p () + "Say whether the buffer contains the first part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (re-search-forward "^=ybegin part=1 " nil t))) + +(defun yenc-last-part-p () + "Say whether the buffer contains the last part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (let (total-size end-size) + (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t) + (setq total-size (match-string 1))) + (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t) + (setq end-size (match-string 1))) + (and total-size + end-size + (string= total-size end-size))))) + ;;;###autoload (defun yenc-decode-region (start end) "Yenc decode region between START and END using an internal decoder." diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2bfd4176567..5aa8860ae9d 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -248,6 +248,8 @@ face (according to `face-differs-from-default-p')." src-file file-name))) +(declare-function ad-get-advice-info "advice" (function)) + ;;;###autoload (defun describe-function-1 (function) (let* ((advised (and (featurep 'advice) (ad-get-advice-info function))) diff --git a/lisp/help.el b/lisp/help.el index ac6af2d9e50..c6650e1cf21 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1029,7 +1029,7 @@ scroll the \"other\" window." ".") (other ", \\[scroll-other-window] to scroll help.") (t ", \\[scroll-up] to scroll help.")))) - (message + (message "%s" (substitute-command-keys (concat quit-part scroll-part))))) (defun help-window-setup-finish (window &optional reuse keep-frame) diff --git a/lisp/gnus/hex-util.el b/lisp/hex-util.el index 981516e4b2a..3a1df204127 100644 --- a/lisp/gnus/hex-util.el +++ b/lisp/hex-util.el @@ -6,21 +6,21 @@ ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: data -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or -;; (at your option) any later version. +;; GNU Emacs 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 3, or (at your option) +;; any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 80133d227ab..b09a3e26979 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -55,6 +55,13 @@ (defvar ibuffer-tmp-hide-regexps) (defvar ibuffer-tmp-show-regexps) +(declare-function ibuffer-mark-on-buffer "ibuf-ext" + (func &optional ibuffer-mark-on-buffer-mark group)) +(declare-function ibuffer-format-qualifier "ibuf-ext" (qualifier)) +(declare-function ibuffer-generate-filter-groups "ibuf-ext" + (bmarklist &optional noempty nodefault)) +(declare-function ibuffer-format-filter-group-data "ibuf-ext" (filter)) + (defgroup ibuffer nil "An advanced replacement for `buffer-menu'. diff --git a/lisp/ido.el b/lisp/ido.el index 0a077f9dab6..4658a887716 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -1309,6 +1309,7 @@ Value is an integer which is number of chars to right of prompt.") (unwind-protect (with-current-buffer buf (erase-buffer) + (insert ";;; -*- coding: utf-8 -*-\n") (setq buffer-file-coding-system 'utf-8) (ido-pp 'ido-last-directory-list) (ido-pp 'ido-work-directory-list) @@ -1317,7 +1318,7 @@ Value is an integer which is number of chars to right of prompt.") (if (listp ido-unc-hosts-cache) (ido-pp 'ido-unc-hosts-cache) (insert "\n;; ----- ido-unc-hosts-cache -----\nt\n")) - (insert "\n;; Local Variables:\n;; coding: utf-8\n;; End:\n") + (insert "\n") (write-file ido-save-directory-list-file nil)) (kill-buffer buf))))) @@ -2281,9 +2282,10 @@ If cursor is not at the end of the user input, move to end of input." filename t)) ((and ido-use-filename-at-point - (setq fn (if (eq ido-use-filename-at-point 'guess) - (with-no-warnings (ffap-guesser)) - (ffap-string-at-point))) + (setq fn (with-no-warnings + (if (eq ido-use-filename-at-point 'guess) + (ffap-guesser) + (ffap-string-at-point)))) (not (string-match "^http:/" fn)) (setq d (file-name-directory fn)) (file-directory-p d)) @@ -3363,6 +3365,8 @@ for first matching file." (nconc ido-temp-list items) (setq ido-temp-list items))) +(declare-function tramp-tramp-file-p "tramp" (name)) + (defun ido-file-name-all-completions-1 (dir) (cond ((ido-nonreadable-directory-p dir) '()) @@ -3370,24 +3374,25 @@ for first matching file." ;; Caller must have done that if necessary. ((and ido-enable-tramp-completion - (or (fboundp 'tramp-completion-mode) + (or (fboundp 'tramp-completion-mode-p) (require 'tramp nil t)) (string-match "\\`/[^/]+[:@]\\'" dir)) ;; Strip method:user@host: part of tramp completions. ;; Tramp completions do not include leading slash. - (let ((len (1- (length dir))) - (compl - (or (file-name-all-completions "" dir) - ;; work around bug in ange-ftp. - ;; /ftp:user@host: => nil - ;; /ftp:user@host:./ => ok - (and - (not (string= "/ftp:" dir)) - (tramp-tramp-file-p dir) - (fboundp 'tramp-ftp-file-name-p) - (funcall 'tramp-ftp-file-name-p dir) - (string-match ":\\'" dir) - (file-name-all-completions "" (concat dir "./")))))) + (let* ((len (1- (length dir))) + (tramp-completion-mode t) + (compl + (or (file-name-all-completions "" dir) + ;; work around bug in ange-ftp. + ;; /ftp:user@host: => nil + ;; /ftp:user@host:./ => ok + (and + (not (string= "/ftp:" dir)) + (tramp-tramp-file-p dir) + (fboundp 'tramp-ftp-file-name-p) + (funcall 'tramp-ftp-file-name-p dir) + (string-match ":\\'" dir) + (file-name-all-completions "" (concat dir "./")))))) (if (and compl (> (length (car compl)) len) (string= (substring (car compl) 0 len) (substring dir 1))) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 82bfbfb20af..cca9686f237 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1184,7 +1184,7 @@ comment." ", ")) (comment (get-text-property (point) 'comment))) (if file-name - (message + (message "%s" (image-dired-format-properties-string dired-buf file-name @@ -1208,7 +1208,7 @@ dired." (if (not (and dired-buf file-name)) (message "No image, or image with correct properties, at point.") (with-current-buffer dired-buf - (message file-name) + (message "%s" file-name) (setq file-name (file-name-nondirectory file-name)) (goto-char (point-min)) (if (search-forward file-name nil t) @@ -2239,7 +2239,7 @@ non-nil." ", ")) (comment (image-dired-get-comment file))) (if file-name - (message + (message "%s" (image-dired-format-properties-string dired-buf file-name diff --git a/lisp/informat.el b/lisp/informat.el index 18a459ba0fe..05be680bfa8 100644 --- a/lisp/informat.el +++ b/lisp/informat.el @@ -32,6 +32,8 @@ (require 'info) +(declare-function texinfo-format-refill "texinfmt" ()) + ;;;###autoload (defun Info-tagify (&optional input-buffer-name) "Create or update Info file tag table in current buffer or in a region." diff --git a/lisp/international/iso-cvt.el b/lisp/international/iso-cvt.el index d7149b8a9bc..f2725e9d854 100644 --- a/lisp/international/iso-cvt.el +++ b/lisp/international/iso-cvt.el @@ -65,7 +65,7 @@ "Spanish translation table.") (defun iso-translate-conventions (from to trans-tab) - "Use the translation table TRANS-TAB to translate the current buffer." + "Translate between FROM and TO using the translation table TRANS-TAB." (save-excursion (save-restriction (narrow-to-region from to) @@ -84,8 +84,8 @@ ;;;###autoload (defun iso-spanish (from to &optional buffer) "Translate net conventions for Spanish to ISO 8859-1. -The region between FROM and TO is translated using -the table `iso-spanish-trans-tab'. +Translate the region between FROM and TO using the table +`iso-spanish-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-spanish-trans-tab)) @@ -102,8 +102,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ("\\\\3" "ß") ) "German translation table. -This table uses an aggressive translation approach and may erroneously -translate too much.") +This table uses an aggressive translation approach +and may erroneously translate too much.") (defvar iso-conservative-german-trans-tab '( @@ -117,8 +117,8 @@ translate too much.") ("\\([-a-zA-Z\"`]\\)\\\\3" "\\1ß") ) "German translation table. -This table uses a conservative translation approach and may translate too -little.") +This table uses a conservative translation approach +and may translate too little.") (defvar iso-german-trans-tab iso-aggressive-german-trans-tab "Currently active translation table for German.") @@ -126,8 +126,8 @@ little.") ;;;###autoload (defun iso-german (from to &optional buffer) "Translate net conventions for German to ISO 8859-1. -The region between FROM and TO is translated using -the table `iso-german-trans-tab'. +Translate the region FROM and TO using the table +`iso-german-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-german-trans-tab)) @@ -199,8 +199,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2tex (from to &optional buffer) "Translate ISO 8859-1 characters to TeX sequences. -The region between FROM and TO is translated using -the table `iso-iso2tex-trans-tab'. +Translate the region between FROM and TO using the table +`iso-iso2tex-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2tex-trans-tab)) @@ -386,14 +386,14 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ("!`" "¡") ) "Translation table for translating TeX sequences to ISO 8859-1 characters. -This table is not exhaustive (and due to TeX's power can never be). It only -contains commonly used sequences.") +This table is not exhaustive (and due to TeX's power can never be). +It only contains commonly used sequences.") ;;;###autoload (defun iso-tex2iso (from to &optional buffer) "Translate TeX sequences to ISO 8859-1 characters. -The region between FROM and TO is translated using -the table `iso-tex2iso-trans-tab'. +Translate the region between FROM and TO using the table +`iso-tex2iso-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-tex2iso-trans-tab)) @@ -581,8 +581,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ("\\\\3" "ß") ) "Translation table for translating German TeX sequences to ISO 8859-1. -This table is not exhaustive (and due to TeX's power can never be). It only -contains commonly used sequences.") +This table is not exhaustive (and due to TeX's power can never be). +It only contains commonly used sequences.") (defvar iso-iso2gtex-trans-tab '( @@ -651,8 +651,8 @@ contains commonly used sequences.") ;;;###autoload (defun iso-gtex2iso (from to &optional buffer) "Translate German TeX sequences to ISO 8859-1 characters. -The region between FROM and TO is translated using -the table `iso-gtex2iso-trans-tab'. +Translate the region between FROM and TO using the table +`iso-gtex2iso-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-gtex2iso-trans-tab)) @@ -660,8 +660,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2gtex (from to &optional buffer) "Translate ISO 8859-1 characters to German TeX sequences. -The region between FROM and TO is translated using -the table `iso-iso2gtex-trans-tab'. +Translate the region between FROM and TO using the table +`iso-iso2gtex-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2gtex-trans-tab)) @@ -679,8 +679,8 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2duden (from to &optional buffer) "Translate ISO 8859-1 characters to Duden sequences. -The region between FROM and TO is translated using -the table `iso-iso2duden-trans-tab'. +Translate the region between FROM and TO using the table +`iso-iso2duden-trans-tab'. Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2duden-trans-tab)) @@ -817,7 +817,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-iso2sgml (from to &optional buffer) "Translate ISO 8859-1 characters in the region to SGML entities. -The entities used are from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". +Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-iso2sgml-trans-tab)) @@ -825,7 +825,7 @@ Optional arg BUFFER is ignored (for use in `format-alist')." ;;;###autoload (defun iso-sgml2iso (from to &optional buffer) "Translate SGML entities in the region to ISO 8859-1 characters. -The entities used are from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". +Use entities from \"ISO 8879:1986//ENTITIES Added Latin 1//EN\". Optional arg BUFFER is ignored (for use in `format-alist')." (interactive "*r") (iso-translate-conventions from to iso-sgml2iso-trans-tab)) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 164c3d7ca99..111c45dd50a 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1459,6 +1459,9 @@ To deactivate it programmatically, use `inactivate-input-method'." (customize-mark-as-set 'default-input-method)) default-input-method) +(defvar toggle-input-method-active nil + "Non-nil inside `toggle-input-method'.") + (defun toggle-input-method (&optional arg interactive) "Enable or disable multilingual text input method for the current buffer. Only one input method can be enabled at any time in a given buffer. @@ -1478,9 +1481,12 @@ When called interactively, the optional arg INTERACTIVE is non-nil, which marks the variable `default-input-method' as set for Custom buffers." (interactive "P\np") + (if toggle-input-method-active + (error "Recursive use of `toggle-input-method'")) (if (and current-input-method (not arg)) (inactivate-input-method) - (let ((default (or (car input-method-history) default-input-method))) + (let ((toggle-input-method-active t) + (default (or (car input-method-history) default-input-method))) (if (and arg default (equal current-input-method default) (> (length input-method-history) 1)) (setq default (nth 1 input-method-history))) @@ -2590,14 +2596,24 @@ See also `locale-charset-language-names', `locale-language-names', system codeset `%s' for this locale." coding-system codeset)))))))) ;; On Windows, override locale-coding-system, - ;; keyboard-coding-system with system codepage. Note: - ;; selection-coding-system is already set in w32select.c. + ;; default-file-name-coding-system, keyboard-coding-system, + ;; terminal-coding-system with system codepage. (when (boundp 'w32-ansi-code-page) (let ((code-page-coding (intern (format "cp%d" w32-ansi-code-page)))) (when (coding-system-p code-page-coding) (unless frame (setq locale-coding-system code-page-coding)) (set-keyboard-coding-system code-page-coding frame) - (set-terminal-coding-system code-page-coding frame)))) + (set-terminal-coding-system code-page-coding frame) + ;; Set default-file-name-coding-system last, so that Emacs + ;; doesn't try to use cpNNNN when it defines keyboard and + ;; terminal encoding. That's because the above two lines + ;; will want to load code-pages.el, where cpNNNN are + ;; defined; if default-file-name-coding-system were set to + ;; cpNNNN while these two lines run, Emacs will want to use + ;; it for encoding the file name it wants to load. And that + ;; will fail, since cpNNNN is not yet usable until + ;; code-pages.el finishes loading. + (setq default-file-name-coding-system code-page-coding)))) (when (eq system-type 'darwin) ;; On Darwin, file names are always encoded in utf-8, no matter diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 541f38d38a3..9ed565eada7 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1112,6 +1112,8 @@ To input symbols and punctuations, type `/' followed by one of `a' to Some infrequent characters are accessed by typing \\, followed by the Cantonese romanization of the respective radical ($(0?f5}(B).")) +(declare-function dos-8+3-filename "dos-fns.el" (filename)) + (defun miscdic-convert (filename &optional dirname) "Convert a dictionary file FILENAME into a Quail package. Optional argument DIRNAME if specified is the directory name under which diff --git a/lisp/isearch-multi.el b/lisp/isearch-multi.el index acd456815a0..9161ef82c7e 100644 --- a/lisp/isearch-multi.el +++ b/lisp/isearch-multi.el @@ -66,15 +66,16 @@ The value is nil when the search still is in the initial buffer.") "Function to call to get the next buffer to search. When this variable is set to a function that returns a buffer, then -after typing another C-s or C-r at a failing search, the search goes +after typing another \\[isearch-forward] or \\[isearch-backward] \ +at a failing search, the search goes to the next buffer in the series and continues searching for the next occurrence. The first argument of this function is the current buffer where the search is currently searching. It defines the base buffer relative to which this function should find the next buffer. When the isearch -direction is backward (when isearch-forward is nil), this function -should return the previous buffer to search. If the second argument of +direction is backward (when `isearch-forward' is nil), this function +should return the previous buffer to search. If the second argument of this function WRAP is non-nil, then it should return the first buffer in the series; and for the backward search, it should return the last buffer in the series.") diff --git a/lisp/log-edit.el b/lisp/log-edit.el index 5c2cf989f62..a2f749ad127 100644 --- a/lisp/log-edit.el +++ b/lisp/log-edit.el @@ -57,6 +57,7 @@ (easy-mmode-defmap log-edit-mode-map `(("\C-c\C-c" . log-edit-done) ("\C-c\C-a" . log-edit-insert-changelog) + ("\C-c\C-d" . log-edit-show-diff) ("\C-c\C-f" . log-edit-show-files) ("\M-n" . log-edit-next-comment) ("\M-p" . log-edit-previous-comment) @@ -79,6 +80,8 @@ ["Insert ChangeLog" log-edit-insert-changelog] ["Add to ChangeLog" log-edit-add-to-changelog] "--" + ["Show diff" log-edit-show-diff + :help "Show the diff for the files to be committed."] ["List files" log-edit-show-files :help "Show the list of relevant files."] "--" @@ -170,6 +173,7 @@ when this variable is set to nil.") (defconst log-edit-files-buf "*log-edit-files*") (defvar log-edit-initial-files nil) (defvar log-edit-callback nil) +(defvar log-edit-diff-function nil) (defvar log-edit-listfun nil) (defvar log-edit-parent-buffer nil) @@ -301,7 +305,7 @@ automatically." (2 font-lock-function-name-face)))) ;;;###autoload -(defun log-edit (callback &optional setup listfun buffer &rest ignore) +(defun log-edit (callback &optional setup params buffer &rest ignore) "Setup a buffer to enter a log message. \\<log-edit-mode-map>The buffer will be put in `log-edit-mode'. If SETUP is non-nil, the buffer is then erased and `log-edit-hook' is run. @@ -309,8 +313,13 @@ Mark and point will be set around the entire contents of the buffer so that it is easy to kill the contents of the buffer with \\[kill-region]. Once you're done editing the message, pressing \\[log-edit-done] will call `log-edit-done' which will end up calling CALLBACK to do the actual commit. -LISTFUN if non-nil is a function of no arguments returning the list of files - that are concerned by the current operation (using relative names). +PARAMS if non-nil is an alist. The keys for the alist can be: +`log-edit-listfun' and `log-edit-diff-function'. The associated +value for `log-edit-listfun' should be a function with not +arguments that returns the list of files that are concerned by +the current operation (using relative names). The associated +value for `log-edit-diff-function' should be a function with no +arguments that displays a diff of the files concerned by the current operation. If BUFFER is non-nil `log-edit' will jump to that buffer, use it to edit the log message and go back to the current buffer when done. Otherwise, it uses the current buffer." @@ -321,7 +330,13 @@ If BUFFER is non-nil `log-edit' will jump to that buffer, use it to edit the (when setup (erase-buffer)) (log-edit-mode) (set (make-local-variable 'log-edit-callback) callback) - (set (make-local-variable 'log-edit-listfun) listfun) + (if (listp params) + (dolist (crt params) + (set (make-local-variable (car crt)) (cdr crt))) + ;; For backward compatibility with log-edit up to version 22.2 + ;; accept non-list PARAMS to mean `log-edit-list'. + (set (make-local-variable 'log-edit-listfun) params)) + (if buffer (set (make-local-variable 'log-edit-parent-buffer) parent)) (set (make-local-variable 'log-edit-initial-files) (log-edit-files)) (when setup (run-hooks 'log-edit-hook)) @@ -417,6 +432,13 @@ If you want to abort the commit, simply delete the buffer." (indent-rigidly (point-min) (point-max) (- log-edit-common-indent common))))) +(defun log-edit-show-diff () + "Show the diff for the files to be committed." + (interactive) + (if (functionp log-edit-diff-function) + (funcall log-edit-diff-function) + (error "Diff functionality has not been setup"))) + (defun log-edit-show-files () "Show the list of files to be committed." (interactive) diff --git a/lisp/longlines.el b/lisp/longlines.el index f043a48c737..57b5742751f 100644 --- a/lisp/longlines.el +++ b/lisp/longlines.el @@ -207,33 +207,39 @@ major mode changes." "Make hard newlines visible by adding a face. With optional argument ARG, make the hard newlines invisible again." (interactive "P") - (let ((buffer-undo-list t) - (mod (buffer-modified-p))) (if arg (longlines-unshow-hard-newlines) (setq longlines-showing t) - (longlines-show-region (point-min) (point-max))) - (set-buffer-modified-p mod))) + (longlines-show-region (point-min) (point-max)))) (defun longlines-show-region (beg end) "Make hard newlines between BEG and END visible." (let* ((pmin (min beg end)) (pmax (max beg end)) (pos (text-property-not-all pmin pmax 'hard nil)) - (inhibit-read-only t)) + (mod (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t) + (inhibit-modification-hooks t)) (while pos (put-text-property pos (1+ pos) 'display - (copy-sequence longlines-show-effect)) - (setq pos (text-property-not-all (1+ pos) pmax 'hard nil))))) + (copy-sequence longlines-show-effect)) + (setq pos (text-property-not-all (1+ pos) pmax 'hard nil))) + (restore-buffer-modified-p mod))) (defun longlines-unshow-hard-newlines () "Make hard newlines invisible again." (interactive) (setq longlines-showing nil) - (let ((pos (text-property-not-all (point-min) (point-max) 'hard nil))) + (let ((pos (text-property-not-all (point-min) (point-max) 'hard nil)) + (mod (buffer-modified-p)) + (buffer-undo-list t) + (inhibit-read-only t) + (inhibit-modification-hooks t)) (while pos (remove-text-properties pos (1+ pos) '(display)) - (setq pos (text-property-not-all (1+ pos) (point-max) 'hard nil))))) + (setq pos (text-property-not-all (1+ pos) (point-max) 'hard nil))) + (restore-buffer-modified-p mod))) ;; Wrapping the paragraphs. diff --git a/lisp/gnus/binhex.el b/lisp/mail/binhex.el index 88f0e20f17c..c1d1316c82e 100644 --- a/lisp/gnus/binhex.el +++ b/lisp/mail/binhex.el @@ -35,23 +35,28 @@ 'char-int 'identity))) +(defgroup binhex nil + "Decoding of BinHex (binary-to-hexadecimal) data." + :group 'mail + :group 'news) + (defcustom binhex-decoder-program "hexbin" "*Non-nil value should be a string that names a binhex decoder. The program should expect to read binhex data on its standard input and write the converted data to its standard output." :type 'string - :group 'gnus-extract) + :group 'binhex) (defcustom binhex-decoder-switches '("-d") "*List of command line flags passed to the command `binhex-decoder-program'." - :group 'gnus-extract + :group 'binhex :type '(repeat string)) (defcustom binhex-use-external (executable-find binhex-decoder-program) "*Use external binhex program." :version "22.1" - :group 'gnus-extract + :group 'binhex :type 'boolean) (defconst binhex-alphabet-decoding-alist diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index ce98a608665..14a0a8d4ef1 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -229,6 +229,9 @@ Type SPC to scroll through this section and its subsections.")))) (setq report-emacs-bug-orig-text (buffer-substring (point-min) (point)))) (goto-char user-point))) +(declare-function Info-menu "info" (menu-item &optional fork)) +(declare-function Info-goto-node "info" (nodename &optional fork)) + (defun report-emacs-bug-info () "Go to the Info node on reporting Emacs bugs." (interactive) diff --git a/lisp/gnus/hashcash.el b/lisp/mail/hashcash.el index 737178b8218..22005ce957e 100644 --- a/lisp/gnus/hashcash.el +++ b/lisp/mail/hashcash.el @@ -126,6 +126,11 @@ For example, you may want to set this to '(\"-Z2\") to reduce header length." (concat (match-string 1 addr) (match-string 2 addr)) addr)) +(declare-function message-narrow-to-headers-or-head "message" ()) +(declare-function message-fetch-field "message" (header &optional not-all)) +(declare-function message-goto-eoh "message" ()) +(declare-function message-narrow-to-headers "message" ()) + (defun hashcash-token-substring () (save-excursion (let ((token "")) diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el index 209b1deacf8..9ef5a02bd26 100644 --- a/lisp/mail/mail-extr.el +++ b/lisp/mail/mail-extr.el @@ -1854,7 +1854,7 @@ place. It affects how `mail-extract-address-components' works." ;; http://www.iso.org/iso/en/prods-services/iso3166ma/02iso-3166-code-lists/list-en1-semic.txt ;; http://www.iana.org/domain-names.htm ;; http://www.iana.org/cctld/cctld-whois.htm -;; Latest change: Mon Jul 8 14:21:59 CEST 2002 +;; Latest change: 2007/11/15 (defconst mail-extr-all-top-level-domains (let ((ob (make-vector 739 0))) @@ -1867,6 +1867,7 @@ place. It affects how `mail-extract-address-components' works." (nth 1 x)))) '( ;; ISO 3166 codes: + ("ac" "Ascension Island") ("ad" "Andorra") ("ae" "United Arab Emirates") ("af" "Afghanistan") @@ -1882,6 +1883,7 @@ place. It affects how `mail-extract-address-components' works." ("at" "Austria" "The Republic of %s") ("au" "Australia") ("aw" "Aruba") + ("ax" "Aland Islands") ("az" "Azerbaijan") ("ba" "Bosnia-Herzegovina") ("bb" "Barbados") @@ -1892,6 +1894,7 @@ place. It affects how `mail-extract-address-components' works." ("bh" "Bahrain") ("bi" "Burundi") ("bj" "Benin") + ("bl" "Saint Barthelemy") ("bm" "Bermuda") ("bn" "Brunei Darussalam") ("bo" "Bolivia" "Republic of %s") @@ -1933,6 +1936,7 @@ place. It affects how `mail-extract-address-components' works." ("er" "Eritrea") ("es" "Spain" "The Kingdom of %s") ("et" "Ethiopia") + ("eu" "European Union") ("fi" "Finland" "The Republic of %s") ("fj" "Fiji") ("fk" "Falkland Islands (Malvinas)") @@ -1944,6 +1948,7 @@ place. It affects how `mail-extract-address-components' works." ("gd" "Grenada") ("ge" "Georgia") ("gf" "French Guiana") + ("gg" "Guernsey") ("gh" "Ghana") ("gi" "Gibraltar") ("gl" "Greenland") @@ -1973,6 +1978,7 @@ place. It affects how `mail-extract-address-components' works." ("ir" "Iran" "Islamic Republic of %s") ("is" "Iceland" "The Republic of %s") ("it" "Italy" "The Italian Republic") + ("je" "Jersey") ("jm" "Jamaica") ("jo" "Jordan") ("jp" "Japan") @@ -2001,6 +2007,8 @@ place. It affects how `mail-extract-address-components' works." ("ma" "Morocco") ("mc" "Monaco") ("md" "Moldova" "The Republic of %s") + ("me" "Montenegro") + ("mf" "Saint Martin (French part)") ("mg" "Madagascar") ("mh" "Marshall Islands") ("mk" "Macedonia" "The Former Yugoslav Republic of %s") @@ -2049,6 +2057,7 @@ place. It affects how `mail-extract-address-components' works." ("qa" "Qatar") ("re" "Reunion (Fr.)") ; In .fr domain ("ro" "Romania") + ("rs" "Serbia") ("ru" "Russia" "Russian Federation") ("rw" "Rwanda") ("sa" "Saudi Arabia") @@ -2112,15 +2121,21 @@ place. It affects how `mail-extract-address-components' works." ("zw" "Zimbabwe" "Republic of %s") ;; Generic Domains: ("aero" t "Air Transport Industry") + ("asia" t "Pan-Asia and Asia Pacific community") ("biz" t "Businesses") + ("cat" t "Catalan language and culture") ("com" t "Commercial") ("coop" t "Cooperative Associations") ("info" t "Info") + ("jobs" t "Employment") + ("mobi" t "Mobile products") ("museum" t "Museums") ("name" t "Individuals") ("net" t "Network") ("org" t "Non-profit Organization") - ;;("pro" t "Credentialed professionals") + ("pro" t "Credentialed professionals") + ("tel" t "Contact data") + ("travel" t "Travel industry") ;;("bitnet" t "Because It's Time NET") ("gov" t "United States Government") ("edu" t "Educational") diff --git a/lisp/mail/mspools.el b/lisp/mail/mspools.el index 514bf4fe5f3..b248ba7dec1 100644 --- a/lisp/mail/mspools.el +++ b/lisp/mail/mspools.el @@ -246,6 +246,11 @@ Buffer is not displayed if SHOW is non-nil." (mspools-mode) ) +(declare-function rmail-get-new-mail "rmail" (&optional file-name)) + +;; External. +(declare-function vm-visit-folder "ext:vm-startup" (folder &optional read-only)) + (defun mspools-visit-spool () "Visit the folder on the current line of the *spools* buffer." (interactive) diff --git a/lisp/mail/reporter.el b/lisp/mail/reporter.el index 596c7ee9627..24dd9ab0c35 100644 --- a/lisp/mail/reporter.el +++ b/lisp/mail/reporter.el @@ -168,6 +168,9 @@ composed.") (goto-char (1+ (nth 1 state))) (current-column))) +(declare-function mail-position-on-field "sendmail" (field &optional soft)) +(declare-function mail-text "sendmail" ()) + (defun reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM. MAILBUF is the mail buffer being composed." diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 4a7bd12ba42..5d276f9c76a 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -184,6 +184,10 @@ please report it with \\[report-emacs-bug].") :group 'rmail-retrieve :type '(repeat (directory))) +(declare-function mail-position-on-field "sendmail" (field &optional soft)) +(declare-function mail-text-start "sendmail" ()) +(declare-function rmail-update-summary "rmailsum" (&rest ignore)) + (defun rmail-probe (prog) "Determine what flavor of movemail PROG is. We do this by executing it with `--version' and analyzing its output." @@ -1515,6 +1519,15 @@ original copy." ;;;; *** Rmail input *** +(declare-function rmail-spam-filter "rmail-spam-filter" (msg)) +(declare-function rmail-summary-goto-msg "rmailsum" (&optional n nowarn skip-rmail)) +(declare-function rmail-summary-mark-undeleted "rmailsum" (n)) +(declare-function rmail-summary-mark-deleted "rmailsum" (&optional n undel)) +(declare-function rfc822-addresses "rfc822" (header-text)) +(declare-function mail-abbrev-make-syntax-table "mailabbrev.el" ()) +(declare-function mail-sendmail-delimit-header "sendmail" ()) +(declare-function mail-header-end "sendmail" ()) + ;; RLK feature not added in this version: ;; argument specifies inbox file or files in various ways. @@ -3282,7 +3295,9 @@ and more whitespace. The returned regular expressions contains (setq subject (regexp-quote subject)) (setq subject (replace-regexp-in-string "[ \t\n]+" "[ \t\n]+" subject t t)) - (concat "^Subject: " + ;; Some mailers insert extra spaces after "Subject:", so allow any + ;; amount of them. + (concat "^Subject:[ \t]+" (if (string= "\\`" (substring rmail-reply-regexp 0 2)) (substring rmail-reply-regexp 2) rmail-reply-regexp) diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index 04982aec349..02bc23fe0c5 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -49,6 +49,9 @@ ;; Rmail Edit mode is suitable only for specially formatted data. (put 'rmail-edit-mode 'mode-class 'special) +(declare-function rmail-summary-disable "" ()) +(declare-function rmail-summary-enable "rmailsum" ()) + (defun rmail-edit-mode () "Major mode for editing the contents of an RMAIL message. The editing commands are the same as in Text mode, together with two commands diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index c479e35beb7..48e2246520b 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -86,6 +86,15 @@ Completion is performed over known labels when reading." rmail-last-label (setq rmail-last-label (rmail-make-label result t)))))) +(declare-function rmail-maybe-set-message-counters "rmail" ()) +(declare-function rmail-display-labels "rmail" ()) +(declare-function rmail-msgbeg "rmail" (n)) +(declare-function rmail-set-message-deleted-p "rmail" (n state)) +(declare-function rmail-message-labels-p "rmail" (msg labels)) +(declare-function rmail-show-message "rmail" (&optional n no-summary)) +(declare-function mail-comma-list-regexp "mail-utils" (labels)) +(declare-function mail-parse-comma-list "mail-utils.el" ()) + (defun rmail-set-label (l state &optional n) (with-current-buffer rmail-buffer (rmail-maybe-set-message-counters) diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el index 3b7ccd72d02..67cea297f0e 100644 --- a/lisp/mail/rmailmsc.el +++ b/lisp/mail/rmailmsc.el @@ -30,6 +30,9 @@ (defvar rmail-current-message) (defvar rmail-inbox-list) +(declare-function rmail-parse-file-inboxes "rmail" ()) +(declare-function rmail-show-message "rmail" (&optional n no-summary)) + ;;;###autoload (defun set-rmail-inbox-list (file-name) "Set the inbox list of the current RMAIL file to FILE-NAME. diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index d85bfc0bfe8..1e9f8379b7b 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -109,6 +109,8 @@ Set `rmail-default-file' to this name as well as returning it." (or read-file (file-name-nondirectory default-file)) (file-name-directory default-file))))))) +(declare-function rmail-update-summary "rmailsum" (&rest ignore)) + ;;; There are functions elsewhere in Emacs that use this function; ;;; look at them before you change the calling method. ;;;###autoload diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el index ba496a31228..bed40cd0820 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -152,6 +152,7 @@ KEYWORDS is a comma-separated list of labels." n)))))) ;; Basic functions +(declare-function rmail-update-summary "rmailsum" (&rest ignore)) (defun rmail-sort-messages (reverse keyfun) "Sort messages of current Rmail file. diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index fd5931fdef9..cde289ed719 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1323,6 +1323,13 @@ argument says to read a file name and use that file as the inbox." (end-of-buffer)) (forward-line -1)) +(declare-function rmail-abort-edit "rmailedit" ()) +(declare-function rmail-cease-edit "rmailedit"()) +(declare-function rmail-set-label "rmailkwd" (l state &optional n)) +(declare-function rmail-output-read-file-name "rmailout" ()) +(declare-function rmail-output-read-rmail-file-name "rmailout" ()) +(declare-function mail-send-and-exit "sendmail" (&optional arg)) + (defvar rmail-summary-edit-map nil) (if rmail-summary-edit-map nil diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index e8d896be246..7d66b5e7ac6 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -1744,6 +1744,9 @@ The seventh argument ACTIONS is a list of actions to take (message "Auto save file for draft message exists; consider M-x mail-recover")) initialized)) +(declare-function dired-view-file "dired" ()) +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) + (defun mail-recover-1 () "Pop up a list of auto-saved draft messages so you can recover one of them." (interactive) @@ -1815,6 +1818,10 @@ The seventh argument ACTIONS is a list of actions to take (setq buffer-file-coding-system default-buffer-file-coding-system)))))))) +(declare-function dired-move-to-filename "dired" (&optional raise-error eol)) +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(declare-function dired-view-file "dired" ()) + (defun mail-recover () "Recover interrupted mail composition from auto-save files. diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index 61e7d0a00eb..c0e581c0310 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -6,11 +6,8 @@ ;; Author: 1993 Barry A. Warsaw <bwarsaw@python.org> ;; Maintainer: Glenn Morris <rgm@gnu.org> ;; Created: February 1993 -;; Last Modified: 1993/09/22 18:58:46 ;; Keywords: mail, news -;; supercite.el revision: 3.54 - ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify @@ -510,10 +507,7 @@ string." ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ;; end user configuration variables -(defconst sc-version "3.1" - "Supercite version number.") -(defconst sc-help-address "bug-supercite@gnu.org" - "Address accepting submissions of bug reports.") +(define-obsolete-variable-alias 'sc-version 'emacs-version "23.1") (defvar sc-mail-info nil "Alist of mail header information gleaned from reply buffer.") @@ -2010,7 +2004,7 @@ cited." If MESSAGE is non-nil (interactively, with no prefix argument), inserts the version string in the current buffer instead." (interactive (not current-prefix-arg)) - (let ((verstr (format "Using Supercite.el %s" sc-version))) + (let ((verstr (format "Using Supercite.el %s" emacs-version))) (if message (message verstr) (insert "`sc-version' says: " verstr)))) @@ -2023,48 +2017,7 @@ more information. Info node `(SC)Top'." (interactive) (describe-function 'sc-describe)) -(defun sc-submit-bug-report () - "Submit a bug report on Supercite via mail." - (interactive) - (require 'reporter) - (and - (y-or-n-p "Do you want to submit a report on Supercite? ") - (reporter-submit-bug-report - sc-help-address - (concat "Supercite version " sc-version) - (list - 'sc-attrib-selection-list - 'sc-auto-fill-region-p - 'sc-blank-lines-after-headers - 'sc-citation-leader - 'sc-citation-delimiter - 'sc-citation-separator - 'sc-citation-leader-regexp - 'sc-citation-root-regexp - 'sc-citation-nonnested-root-regexp - 'sc-citation-delimiter-regexp - 'sc-citation-separator-regexp - 'sc-cite-region-limit - 'sc-confirm-always-p - 'sc-default-attribution - 'sc-default-author-name - 'sc-downcase-p - 'sc-electric-circular-p - 'sc-electric-references-p - 'sc-fixup-whitespace-p - 'sc-mail-warn-if-non-rfc822-p - 'sc-mumble - 'sc-name-filter-alist - 'sc-nested-citation-p - 'sc-nuke-mail-headers - 'sc-nuke-mail-header-list - 'sc-preferred-attribution-list - 'sc-preferred-header-style - 'sc-reference-tag-string - 'sc-rewrite-header-list - 'sc-titlecue-regexp - 'sc-use-only-preference-p - )))) +(define-obsolete-function-alias 'sc-submit-bug-report 'report-emacs-bug "23.1") ;; useful stuff diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el index 61afd248332..5a4e01ae9fc 100644 --- a/lisp/mail/uce.el +++ b/lisp/mail/uce.el @@ -217,6 +217,14 @@ These are mostly meant for headers that prevent delivery errors reporting." :type 'string :group 'uce) +(declare-function mail-strip-quoted-names "mail-utils" (address)) +(declare-function rmail-msg-is-pruned "rmail" ()) +(declare-function rmail-maybe-set-message-counters "rmail" ()) +(declare-function rmail-msgbeg "rmail" (n)) +(declare-function rmail-msgend "rmail" (n)) +(declare-function rmail-toggle-header "rmail" (&optional arg)) + + (defun uce-reply-to-uce (&optional ignored) "Send reply to UCE in Rmail. UCE stands for unsolicited commercial email. Function will set up reply diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el index 5d6f266b3b0..9bb2f3eab90 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -153,6 +153,8 @@ See rmail-digest-methods." ;; Return the list of marker pairs (nreverse result)))) +(declare-function rmail-update-summary "rmailsum" (&rest ignore)) + ;;;###autoload (defun undigestify-rmail-message () "Break up a digest message into its constituent messages. diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el index f1cf85a4ffc..7ad1c69b50d 100644 --- a/lisp/mail/unrmail.el +++ b/lisp/mail/unrmail.el @@ -48,6 +48,8 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'." (message "Done") (kill-emacs (if error 1 0)))) +(declare-function mail-strip-quoted-names "mail-utils" (address)) + ;;;###autoload (defun unrmail (file to-file) "Convert Rmail file FILE to system inbox format file TO-FILE." diff --git a/lisp/gnus/uudecode.el b/lisp/mail/uudecode.el index 74abeff6621..9dc430e825d 100644 --- a/lisp/gnus/uudecode.el +++ b/lisp/mail/uudecode.el @@ -35,23 +35,28 @@ 'char-int 'identity))) +(defgroup uudecode nil + "Decoding of uuencoded data." + :group 'mail + :group 'news) + (defcustom uudecode-decoder-program "uudecode" "*Non-nil value should be a string that names a uu decoder. The program should expect to read uu data on its standard input and write the converted data to its standard output." :type 'string - :group 'gnus-extract) + :group 'uudecode) (defcustom uudecode-decoder-switches nil "*List of command line flags passed to `uudecode-decoder-program'." - :group 'gnus-extract + :group 'uudecode :type '(repeat string)) (defcustom uudecode-use-external (executable-find uudecode-decoder-program) "*Use external uudecode program." :version "22.1" - :group 'gnus-extract + :group 'uudecode :type 'boolean) (defconst uudecode-alphabet "\040-\140") diff --git a/lisp/mail/vms-pmail.el b/lisp/mail/vms-pmail.el index 022a8070a2e..9785fed71e6 100644 --- a/lisp/mail/vms-pmail.el +++ b/lisp/mail/vms-pmail.el @@ -1,3 +1,4 @@ +;; -*- no-byte-compile: t -*- ;;; vms-pmail.el --- use Emacs as the editor within VMS mail ;; Copyright (C) 1992, 2001, 2002, 2003, 2004, 2005, diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in index 96d69dc0bb7..1998dc6d590 100644 --- a/lisp/makefile.w32-in +++ b/lisp/makefile.w32-in @@ -84,6 +84,7 @@ WINS_ALMOST=\ mail \ mh-e \ net \ + nxml \ play \ progmodes \ term \ diff --git a/lisp/man.el b/lisp/man.el index fc84f327271..41f1d37bb18 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -264,14 +264,17 @@ the associated section number." "(\\(" Man-section-regexp "\\))\\).*\\1")) "Regular expression describing the heading of a page.") -(defvar Man-heading-regexp "^\\([A-Z][A-Z /-]+\\)$" +(defvar Man-heading-regexp "^\\([A-Z][A-Z0-9 /-]+\\)$" "Regular expression describing a manpage heading entry.") (defvar Man-see-also-regexp "SEE ALSO" "Regular expression for SEE ALSO heading (or your equivalent). This regexp should not start with a `^' character.") -(defvar Man-first-heading-regexp "^[ \t]*NAME$\\|^[ \t]*No manual entry fo.*$" +;; This used to have leading space [ \t]*, but was removed because it +;; causes false page splits on an occasional NAME with leading space +;; inside a manpage. And `Man-heading-regexp' doesn't have [ \t]* anyway. +(defvar Man-first-heading-regexp "^NAME$\\|^[ \t]*No manual entry fo.*$" "Regular expression describing first heading on a manpage. This regular expression should start with a `^' character.") @@ -763,17 +766,16 @@ all sections related to a subject, put something appropriate into the ;; minal (using an ioctl(2) if available, the value of ;; $COLUMNS, or falling back to 80 characters if nei- ;; ther is available). - (if window-system - (unless (or (getenv "MANWIDTH") (getenv "COLUMNS")) - ;; This isn't strictly correct, since we don't know how - ;; the page will actually be displayed, but it seems - ;; reasonable. - (setenv "COLUMNS" (number-to-string - (cond - ((and (integerp Man-width) (> Man-width 0)) - Man-width) - (Man-width (frame-width)) - ((window-width))))))) + (unless (or (getenv "MANWIDTH") (getenv "COLUMNS")) + ;; This isn't strictly correct, since we don't know how + ;; the page will actually be displayed, but it seems + ;; reasonable. + (setenv "COLUMNS" (number-to-string + (cond + ((and (integerp Man-width) (> Man-width 0)) + Man-width) + (Man-width (frame-width)) + ((window-width)))))) (setenv "GROFF_NO_SGR" "1") (if (fboundp 'start-process) (set-process-sentinel diff --git a/lisp/gnus/md4.el b/lisp/md4.el index aa9bc543203..7ccb22a20fe 100644 --- a/lisp/gnus/md4.el +++ b/lisp/md4.el @@ -1,26 +1,26 @@ ;;; md4.el --- MD4 Message Digest Algorithm. -;; Copyright (C) 2004 Free Software Foundation, Inc. -;; Copyright (C) 2001 Taro Kawagishi +;; Copyright (C) 2001, 2004, 2007 Free Software Foundation, Inc. + ;; Author: Taro Kawagishi <tarok@transpulse.org> ;; Keywords: MD4 ;; Version: 1.00 ;; Created: February 2001 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs 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 3, or (at your option) ;; any later version. -;; -;; This program is distributed in the hope that it will be useful, + +;; GNU Emacs 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. -;; + ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index c05a4e66a9a..2f4c95d6484 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -504,11 +504,14 @@ A large number or nil slows down menu responsiveness." ;; These are alternative definitions for the cut, paste and copy ;; menu items. Use them if your system expects these to use the clipboard. -(put 'clipboard-kill-region 'menu-enable 'mark-active) +(put 'clipboard-kill-region 'menu-enable + '(and mark-active (not buffer-read-only))) (put 'clipboard-kill-ring-save 'menu-enable 'mark-active) (put 'clipboard-yank 'menu-enable - '(or (and (fboundp 'x-selection-exists-p) (x-selection-exists-p)) - (x-selection-exists-p 'CLIPBOARD))) + '(and (or (and (fboundp 'x-selection-exists-p) + (x-selection-exists-p)) + (x-selection-exists-p 'CLIPBOARD)) + (not buffer-read-only))) (defun clipboard-yank () "Insert the clipboard contents, or the last stretch of killed text." @@ -1340,10 +1343,10 @@ key, a click, or a menu-item")) '(menu-item "Introduction to Emacs Lisp" menu-bar-read-lispintro :help "Read the Introduction to Emacs Lisp Programming")) -(define-key menu-bar-help-menu [describe-project] +(define-key menu-bar-help-menu [about-gnu-project] '(menu-item "About GNU" describe-project :help "About the GNU System, GNU Project, and GNU/Linux")) -(define-key menu-bar-help-menu [about] +(define-key menu-bar-help-menu [about-emacs] '(menu-item "About Emacs" about-emacs :help "Display version number, copyright info, and basic help")) (define-key menu-bar-help-menu [sep4] @@ -1354,7 +1357,7 @@ key, a click, or a menu-item")) (define-key menu-bar-help-menu [describe-copying] '(menu-item "Copying Conditions" describe-copying :help "Show the Emacs license (GPL)")) -(define-key menu-bar-help-menu [describe-distribution] +(define-key menu-bar-help-menu [getting-new-versions] '(menu-item "Getting New Versions" describe-distribution :help "How to get latest versions of Emacs")) (defun menu-bar-help-extra-packages () @@ -1366,10 +1369,10 @@ key, a click, or a menu-item")) (goto-address))) (define-key menu-bar-help-menu [sep2] '("--")) -(define-key menu-bar-help-menu [more] +(define-key menu-bar-help-menu [external-packages] '(menu-item "External Packages" menu-bar-help-extra-packages :help "Lisp packages distributed separately for use in Emacs")) -(define-key menu-bar-help-menu [finder-by-keyword] +(define-key menu-bar-help-menu [find-emacs-packages] '(menu-item "Find Emacs Packages" finder-by-keyword :help "Find packages and features by keyword")) (define-key menu-bar-help-menu [more-manuals] @@ -1383,10 +1386,10 @@ key, a click, or a menu-item")) (list 'menu-item "Search Documentation" menu-bar-search-documentation-menu)) (define-key menu-bar-help-menu [sep1] '("--")) -(define-key menu-bar-help-menu [eliza] +(define-key menu-bar-help-menu [emacs-psychotherapist] '(menu-item "Emacs Psychotherapist" doctor :help "Our doctor will help you feel better")) -(define-key menu-bar-help-menu [report-emacs-bug] +(define-key menu-bar-help-menu [send-emacs-bug-report] '(menu-item "Send Bug Report..." report-emacs-bug :help "Send e-mail to Emacs maintainers")) (define-key menu-bar-help-menu [emacs-known-problems] @@ -1772,6 +1775,8 @@ See `menu-bar-mode' for more information." (menu-bar-mode (if (> (frame-parameter nil 'menu-bar-lines) 0) 0 1)) (menu-bar-mode arg))) +(declare-function x-menu-bar-open "term/x-win" (&optional frame)) + (defun menu-bar-open (&optional frame) "Start key navigation of the menu bar in FRAME. diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog index 2619e20e6f7..f82859475a3 100644 --- a/lisp/mh-e/ChangeLog +++ b/lisp/mh-e/ChangeLog @@ -1,3 +1,20 @@ +2007-12-02 Glenn Morris <rgm@gnu.org> + + * mh-mime.el (mail-strip-quoted-names): Autoload it. + +2007-11-17 Dan Nicolaescu <dann@ics.uci.edu> + + * mh-e.el (mh-xemacs-flag): Remove. + (mh-min-colors-defined-flag): + * mh-xface.el (mh-show-xface-function): + * mh-utils.el (mh-colors-available-p): + * mh-show.el (mh-show-mode): + * mh-gnus.el (mh-gnus-local-map-property): + * mh-folder.el (mh-folder-mode-map) + (mh-remove-xemacs-horizontal-scrollbar, mh-folder-mode): + * mh-comp.el (mh-insert-x-mailer): Replace uses of mh-xemacs-flag + with (featurep 'xemacs). + 2007-09-11 Bill Wohler <wohler@newt.com> * mh-e.el (Version, mh-version): Add +cvs to version. diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index bb2d1506adf..2dcc3d52825 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -928,8 +928,8 @@ The versions of MH-E, Emacs, and MH are shown." (setq mh-x-mailer-string (format "MH-E %s; %s; %sEmacs %s" mh-version mh-variant-in-use - (if mh-xemacs-flag "X" "GNU ") - (cond ((not mh-xemacs-flag) + (if (featurep 'xemacs) "X" "GNU ") + (cond ((not (featurep 'xemacs)) (string-match "[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)?" emacs-version) (match-string 0 emacs-version)) diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index faec4db35b7..69454110701 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -99,10 +99,6 @@ (require 'mh-buffers) (require 'mh-compat) -(eval-and-compile - (defvar mh-xemacs-flag (featurep 'xemacs) - "Non-nil means the current Emacs is XEmacs.")) - (mh-do-in-xemacs (require 'mh-xemacs)) @@ -3398,7 +3394,7 @@ consumed by `defface-mh'.") The :inherit keyword is available on all supported versions of GNU Emacs and XEmacs from at least 21.5.23 on.") -(defvar mh-min-colors-defined-flag (and (not mh-xemacs-flag) +(defvar mh-min-colors-defined-flag (and (not (featurep 'xemacs)) (>= emacs-major-version 22)) "Non-nil means `defface' supports min-colors display requirement.") diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index 75cebfe519d..bc15d3eb118 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -351,7 +351,7 @@ annotation.") "\M-\t" mh-prev-button) (cond - (mh-xemacs-flag + ((featurep 'xemacs) (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) (t (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) @@ -513,7 +513,7 @@ font-lock is done highlighting.") (defmacro mh-remove-xemacs-horizontal-scrollbar () "Get rid of the horizontal scrollbar that XEmacs insists on putting in." - (when mh-xemacs-flag + (when (featurep 'xemacs) `(if (and (featurep 'scrollbar) (fboundp 'set-specifier)) (set-specifier horizontal-scrollbar-visible-p nil @@ -656,7 +656,7 @@ perform the operation on all messages in that region. (easy-menu-add mh-folder-folder-menu) (mh-inc-spool-make) (mh-set-help mh-folder-mode-help-messages) - (if (and mh-xemacs-flag + (if (and (featurep 'xemacs) font-lock-auto-fontify) (turn-on-font-lock))) ; Force font-lock in XEmacs. diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el index 0624346ca05..e099c2e726b 100644 --- a/lisp/mh-e/mh-gnus.el +++ b/lisp/mh-e/mh-gnus.el @@ -41,7 +41,7 @@ ;; Copy of function from gnus-util.el. (defun-mh mh-gnus-local-map-property gnus-local-map-property (map) "Return a list suitable for a text property list specifying keymap MAP." - (cond (mh-xemacs-flag (list 'keymap map)) + (cond ((featurep 'xemacs) (list 'keymap map)) ((>= emacs-major-version 21) (list 'keymap map)) (t (list 'local-map map)))) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index 659ab47d0db..10bfeb9c59a 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -60,6 +60,7 @@ (autoload 'mail-decode-encoded-word-string "mail-parse") (autoload 'mail-header-parse-content-type "mail-parse") (autoload 'mail-header-strip "mail-parse") +(autoload 'mail-strip-quoted-names "mail-utils") (autoload 'message-options-get "message") (autoload 'message-options-set "message") (autoload 'message-options-set-recipient "message") diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index fd171107ac3..c97715dabf3 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -872,7 +872,7 @@ See also `mh-folder-mode'. (mh-gnus-article-highlight-citation)) (t (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (if (and mh-xemacs-flag + (if (and (featurep 'xemacs) font-lock-auto-fontify) (turn-on-font-lock)) (when mh-decode-mime-flag diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 5b618e35b87..da2ace3fd2c 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -67,7 +67,7 @@ used in lieu of `search' in the CL package." ;;;###mh-autoload (defun mh-colors-available-p () "Check if colors are available in the Emacs being used." - (or mh-xemacs-flag + (or (featurep 'xemacs) (let ((color-cells (mh-display-color-cells))) (and (numberp color-cells) (>= color-cells 8))))) diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 8445cf32ed1..a6a6efc0fb2 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -36,7 +36,7 @@ (autoload 'message-fetch-field "message") (defvar mh-show-xface-function - (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) + (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface))) (load "x-face" t t) #'mh-face-display-function) ((>= emacs-major-version 21) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 523588ec7c2..d7c5228945c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -825,6 +825,7 @@ to use." ;; --- Default MS-Windows browser --- (defvar dos-windows-version) +(declare-function w32-shell-execute "w32fns.c") ;; Defined in C. (defun browse-url-default-windows-browser (url &optional new-window) (interactive (browse-url-interactive-arg "URL: ")) @@ -1283,6 +1284,10 @@ used instead of `browse-url-new-window-flag'." ;; --- W3 --- +;; External. +(declare-function w3-fetch-other-window "ext:w3m" (&optional url)) +(declare-function w3-fetch "ext:w3m" (&optional url target)) + ;;;###autoload (defun browse-url-w3 (url &optional new-window) "Ask the w3 WWW browser to load URL. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el new file mode 100644 index 00000000000..9221c52a082 --- /dev/null +++ b/lisp/net/dbus.el @@ -0,0 +1,291 @@ +;;; -*- no-byte-compile: t; -*- +;;; dbus.el --- Elisp bindings for D-Bus. + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, hardware + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, see +;; <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides language bindings for the D-Bus API. D-Bus +;; is a message bus system, a simple way for applications to talk to +;; one another. See <http://dbus.freedesktop.org/> for details. + +;; Low-level language bindings are implemented in src/dbusbind.c. + +;;; Code: + +(require 'xml) + +(defconst dbus-service-dbus "org.freedesktop.DBus" + "The bus name used to talk to the bus itself.") + +(defconst dbus-path-dbus "/org/freedesktop/DBus" + "The object path used to talk to the bus itself.") + +(defconst dbus-interface-dbus "org.freedesktop.DBus" + "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") + +(defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable" + "The interface supported by introspectable objects.") + + +;;; Hash table of registered functions. + +(defun dbus-hash-table= (x y) + "Compares keys X and Y in the hash table of registered functions for D-Bus. +See `dbus-registered-functions-table' for a description of the hash table." + (and + (listp x) (listp y) + ;; Bus symbol, either :system or :session. + (symbolp (car x)) (symbolp (car y)) (equal (car x) (car y)) + ;; Interface. + (or + (null (cadr x)) (null (cadr y)) ; wildcard + (and + (stringp (cadr x)) (stringp (cadr y)) (string-equal (cadr x) (cadr y)))) + ;; Member. + (or + (null (caddr x)) (null (caddr y)) ; wildcard + (and + (stringp (caddr x)) (stringp (caddr y)) + (string-equal (caddr x) (caddr y)))))) + +(define-hash-table-test 'dbus-hash-table-test 'dbus-hash-table= 'sxhash) + +;; When we assume that interface and and member are always strings in +;; the key, we could use `equal' as test function. But we want to +;; have also `nil' there, being a wildcard. +(setq dbus-registered-functions-table + (make-hash-table :test 'dbus-hash-table-test)) + + +;;; D-Bus events. + +(defun dbus-check-event (event) + "Checks whether EVENT is a well formed D-Bus event. +EVENT is a list which starts with symbol `dbus-event': + + (dbus-event HANDLER BUS SERVICE PATH INTERFACE MEMBER &rest ARGS) + +HANDLER is the function which has been registered for this +signal. BUS identifies the D-Bus the signal is coming from. It +is either the symbol `:system' or the symbol `:session'. SERVICE +and PATH are the name and the object path of the D-Bus object +emitting the signal. INTERFACE and MEMBER denote the signal +which has been sent. ARGS are the arguments passed to HANDLER, +when it is called during event handling in `dbus-handle-event'. + +This function raises a `dbus-error' signal in case the event is +not well formed." + (when dbus-debug (message "DBus-Event %s" event)) + (unless (and (listp event) + (eq (car event) 'dbus-event) + ;; Handler. + (functionp (nth 1 event)) + ;; Bus symbol. + (symbolp (nth 2 event)) + ;; Service. + (stringp (nth 3 event)) + ;; Object path. + (stringp (nth 4 event)) + ;; Interface. + (stringp (nth 5 event)) + ;; Member. + (stringp (nth 6 event))) + (signal 'dbus-error (list "Not a valid D-Bus event" event)))) + +;;;###autoload +(defun dbus-handle-event (event) + "Handle events from the D-Bus. +EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being +part of the event, is called with arguments ARGS." + (interactive "e") + ;; We don't want to raise an error, because this function is called + ;; in the event handling loop. + (condition-case nil + (progn + (dbus-check-event event) + (apply (cadr event) (nthcdr 7 event))) + (dbus-error))) + +(defun dbus-event-bus-name (event) + "Return the bus name the event is coming from. +The result is either the symbol `:system' or the symbol `:session'. +EVENT is a D-Bus event, see `dbus-check-event'. This function +raises a `dbus-error' signal in case the event is not well +formed." + (dbus-check-event event) + (nth 2 event)) + +(defun dbus-event-service-name (event) + "Return the name of the D-Bus object the event is coming from. +The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. +This function raises a `dbus-error' signal in case the event is +not well formed." + (dbus-check-event event) + (nth 3 event)) + +(defun dbus-event-path-name (event) + "Return the object path of the D-Bus object the event is coming from. +The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. +This function raises a `dbus-error' signal in case the event is +not well formed." + (dbus-check-event event) + (nth 4 event)) + +(defun dbus-event-interface-name (event) + "Return the interface name of the D-Bus object the event is coming from. +The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. +This function raises a `dbus-error' signal in case the event is +not well formed." + (dbus-check-event event) + (nth 5 event)) + +(defun dbus-event-member-name (event) + "Return the member name the event is coming from. +It is either a signal name or a method name. The result is is a +string. EVENT is a D-Bus event, see `dbus-check-event'. This +function raises a `dbus-error' signal in case the event is not +well formed." + (dbus-check-event event) + (nth 6 event)) + + +;;; D-Bus registered names. + +(defun dbus-list-activatable-names () + "Return the D-Bus service names which can be activated as list. +The result is a list of strings, which is nil when there are no +activatable service names at all." + (condition-case nil + (dbus-call-method + :system "ListActivatableNames" dbus-service-dbus + dbus-path-dbus dbus-interface-dbus) + (dbus-error))) + +(defun dbus-list-names (bus) + "Return the service names registered at D-Bus BUS. +The result is a list of strings, which is nil when there are no +registered service names at all. Well known names are strings like +\"org.freedesktop.DBus\". Names starting with \":\" are unique names +for services." + (condition-case nil + (dbus-call-method + bus "ListNames" dbus-service-dbus dbus-path-dbus dbus-interface-dbus) + (dbus-error))) + +(defun dbus-list-known-names (bus) + "Retrieve all services which correspond to a known name in BUS. +A service has a known name if it doesn't start with \":\"." + (let (result) + (dolist (name (dbus-list-names bus) result) + (unless (string-equal ":" (substring name 0 1)) + (add-to-list 'result name 'append))))) + +(defun dbus-list-queued-owners (bus service) +"Return the unique names registered at D-Bus BUS and queued for SERVICE. +The result is a list of strings, or nil when there are no queued name +owners service names at all." + (condition-case nil + (dbus-call-method + bus "ListQueuedOwners" dbus-service-dbus + dbus-path-dbus dbus-interface-dbus service) + (dbus-error))) + +(defun dbus-get-name-owner (bus service) + "Return the name owner of SERVICE registered at D-Bus BUS. +The result is either a string, or nil if there is no name owner." + (condition-case nil + (dbus-call-method + bus "GetNameOwner" dbus-service-dbus + dbus-path-dbus dbus-interface-dbus service) + (dbus-error))) + +(defun dbus-introspect (bus service path) + "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. +The data are in XML format. + +Example: + +\(dbus-introspect + :system \"org.freedesktop.Hal\" + \"/org/freedesktop/Hal/devices/computer\"))" + (condition-case nil + (dbus-call-method + bus "Introspect" service path dbus-interface-introspectable) + (dbus-error))) + +(if nil ;; Must be reworked. Shall we offer D-Bus signatures at all? +(defun dbus-get-signatures (bus interface signal) + "Retrieve SIGNAL's type signatures from D-Bus. +The result is a list of SIGNAL's type signatures. Example: + + \(\"s\" \"b\" \"ai\"\) + +This list represents 3 parameters of SIGNAL. The first parameter +is of type string, the second parameter is of type boolean, and +the third parameter is of type array of integer. + +If INTERFACE or SIGNAL do not exist, or if they do not support +the D-Bus method org.freedesktop.DBus.Introspectable.Introspect, +the function returns nil." + (condition-case nil + (let ((introspect-xml + (with-temp-buffer + (insert (dbus-introspect bus interface)) + (xml-parse-region (point-min) (point-max)))) + node interfaces signals args result) + ;; Get the root node. + (setq node (xml-node-name introspect-xml)) + ;; Get all interfaces. + (setq interfaces (xml-get-children node 'interface)) + (while interfaces + (when (string-equal (xml-get-attribute (car interfaces) 'name) + interface) + ;; That's the requested interface. Check for signals. + (setq signals (xml-get-children (car interfaces) 'signal)) + (while signals + (when (string-equal (xml-get-attribute (car signals) 'name) + signal) + ;; The signal we are looking for. + (setq args (xml-get-children (car signals) 'arg)) + (while args + (unless (xml-get-attribute (car args) 'type) + ;; This shouldn't happen, let's escape. + (signal 'dbus-error "")) + ;; We append the signature. + (setq + result (append result + (list (xml-get-attribute (car args) 'type)))) + (setq args (cdr args))) + (setq signals nil)) + (setq signals (cdr signals))) + (setq interfaces nil)) + (setq interfaces (cdr interfaces))) + result) + ;; We ignore `dbus-error'. There might be no introspectable interface. + (dbus-error nil))) +) ;; (if nil ... + +(provide 'dbus) + +;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd +;;; dbus.el ends here diff --git a/lisp/gnus/dig.el b/lisp/net/dig.el index 9d62fdc9919..cee3a5c17cc 100644 --- a/lisp/gnus/dig.el +++ b/lisp/net/dig.el @@ -151,7 +151,10 @@ Buffer should contain output generated by `dig-invoke'." '(dig-font-lock-keywords t))) (when (featurep 'font-lock) (font-lock-set-defaults)) - (gnus-run-mode-hooks 'dig-mode-hook)) + (save-current-buffer + (if (fboundp 'run-mode-hooks) + (run-mode-hooks 'dig-mode-hook) + (run-hooks 'dig-mode-hook)))) (defun dig-exit () "Quit dig output buffer." diff --git a/lisp/gnus/dns.el b/lisp/net/dns.el index 7910261125a..9f8776ed709 100644 --- a/lisp/gnus/dns.el +++ b/lisp/net/dns.el @@ -1,6 +1,7 @@ ;;; dns.el --- Domain Name Service lookups -;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: network @@ -26,10 +27,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - -(require 'mm-util) - (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") @@ -105,10 +102,11 @@ If nil, /etc/resolv.conf will be consulted.") (dns-write-bytes 0)) (defun dns-read-string-name (string buffer) - (mm-with-unibyte-buffer - (insert string) - (goto-char (point-min)) - (dns-read-name buffer))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (dns-read-name buffer)))) (defun dns-read-name (&optional buffer) (let ((ended nil) @@ -188,71 +186,72 @@ If TCP-P, the first two bytes of the package with be the length field." (buffer-string))) (defun dns-read (packet) - (mm-with-unibyte-buffer - (let ((spec nil) - queries answers authorities additionals) - (insert packet) - (goto-char (point-min)) - (push (list 'id (dns-read-bytes 2)) spec) - (let ((byte (dns-read-bytes 1))) - (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) - spec) - (let ((opcode (logand byte (lsh 7 3)))) - (push (list 'opcode - (cond ((eq opcode 0) 'query) - ((eq opcode 1) 'inverse-query) - ((eq opcode 2) 'status))) - spec)) - (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) - nil t)) spec) - (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) - spec) - (push (list 'recursion-desired-p - (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) - (let ((rc (logand (dns-read-bytes 1) 15))) - (push (list 'response-code - (cond - ((eq rc 0) 'no-error) - ((eq rc 1) 'format-error) - ((eq rc 2) 'server-failure) - ((eq rc 3) 'name-error) - ((eq rc 4) 'not-implemented) - ((eq rc 5) 'refused))) - spec)) - (setq queries (dns-read-bytes 2)) - (setq answers (dns-read-bytes 2)) - (setq authorities (dns-read-bytes 2)) - (setq additionals (dns-read-bytes 2)) - (let ((qs nil)) - (dotimes (i queries) - (push (list (dns-read-name) - (list 'type (dns-inverse-get (dns-read-bytes 2) - dns-query-types)) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes))) - qs)) - (push (list 'queries qs) spec)) - (dolist (slot '(answers authorities additionals)) - (let ((qs nil) - type) - (dotimes (i (symbol-value slot)) - (push (list (dns-read-name) - (list 'type - (setq type (dns-inverse-get (dns-read-bytes 2) - dns-query-types))) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes)) - (list 'ttl (dns-read-bytes 4)) - (let ((length (dns-read-bytes 2))) - (list 'data - (dns-read-type - (buffer-substring - (point) - (progn (forward-char length) (point))) - type)))) - qs)) - (push (list slot qs) spec))) - (nreverse spec)))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (let ((spec nil) + queries answers authorities additionals) + (insert packet) + (goto-char (point-min)) + (push (list 'id (dns-read-bytes 2)) spec) + (let ((byte (dns-read-bytes 1))) + (push (list 'response-p (if (zerop (logand byte (lsh 1 7))) nil t)) + spec) + (let ((opcode (logand byte (lsh 7 3)))) + (push (list 'opcode + (cond ((eq opcode 0) 'query) + ((eq opcode 1) 'inverse-query) + ((eq opcode 2) 'status))) + spec)) + (push (list 'authoritative-p (if (zerop (logand byte (lsh 1 2))) + nil t)) spec) + (push (list 'truncated-p (if (zerop (logand byte (lsh 1 2))) nil t)) + spec) + (push (list 'recursion-desired-p + (if (zerop (logand byte (lsh 1 0))) nil t)) spec)) + (let ((rc (logand (dns-read-bytes 1) 15))) + (push (list 'response-code + (cond + ((eq rc 0) 'no-error) + ((eq rc 1) 'format-error) + ((eq rc 2) 'server-failure) + ((eq rc 3) 'name-error) + ((eq rc 4) 'not-implemented) + ((eq rc 5) 'refused))) + spec)) + (setq queries (dns-read-bytes 2)) + (setq answers (dns-read-bytes 2)) + (setq authorities (dns-read-bytes 2)) + (setq additionals (dns-read-bytes 2)) + (let ((qs nil)) + (dotimes (i queries) + (push (list (dns-read-name) + (list 'type (dns-inverse-get (dns-read-bytes 2) + dns-query-types)) + (list 'class (dns-inverse-get (dns-read-bytes 2) + dns-classes))) + qs)) + (push (list 'queries qs) spec)) + (dolist (slot '(answers authorities additionals)) + (let ((qs nil) + type) + (dotimes (i (symbol-value slot)) + (push (list (dns-read-name) + (list 'type + (setq type (dns-inverse-get (dns-read-bytes 2) + dns-query-types))) + (list 'class (dns-inverse-get (dns-read-bytes 2) + dns-classes)) + (list 'ttl (dns-read-bytes 4)) + (let ((length (dns-read-bytes 2))) + (list 'data + (dns-read-type + (buffer-substring + (point) + (progn (forward-char length) (point))) + type)))) + qs)) + (push (list slot qs) spec))) + (nreverse spec))))) (defun dns-read-int32 () ;; Full 32 bit Integers can't be handled by Emacs. If we use @@ -264,38 +263,40 @@ If TCP-P, the first two bytes of the package with be the length field." (let ((buffer (current-buffer)) (point (point))) (prog1 - (mm-with-unibyte-buffer - (insert string) - (goto-char (point-min)) - (cond - ((eq type 'A) - (let ((bytes nil)) - (dotimes (i 4) - (push (dns-read-bytes 1) bytes)) - (mapconcat 'number-to-string (nreverse bytes) "."))) - ((eq type 'AAAA) - (let (hextets) - (dotimes (i 8) - (push (dns-read-bytes 2) hextets)) - (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) - ((eq type 'SOA) - (list (list 'mname (dns-read-name buffer)) - (list 'rname (dns-read-name buffer)) - (list 'serial (dns-read-int32)) - (list 'refresh (dns-read-int32)) - (list 'retry (dns-read-int32)) - (list 'expire (dns-read-int32)) - (list 'minimum (dns-read-int32)))) - ((eq type 'SRV) - (list (list 'priority (dns-read-bytes 2)) - (list 'weight (dns-read-bytes 2)) - (list 'port (dns-read-bytes 2)) - (list 'target (dns-read-name buffer)))) - ((eq type 'MX) - (cons (dns-read-bytes 2) (dns-read-name buffer))) - ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) - (dns-read-string-name string buffer)) - (t string))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (cond + ((eq type 'A) + (let ((bytes nil)) + (dotimes (i 4) + (push (dns-read-bytes 1) bytes)) + (mapconcat 'number-to-string (nreverse bytes) "."))) + ((eq type 'AAAA) + (let (hextets) + (dotimes (i 8) + (push (dns-read-bytes 2) hextets)) + (mapconcat (lambda (n) (format "%x" n)) + (nreverse hextets) ":"))) + ((eq type 'SOA) + (list (list 'mname (dns-read-name buffer)) + (list 'rname (dns-read-name buffer)) + (list 'serial (dns-read-int32)) + (list 'refresh (dns-read-int32)) + (list 'retry (dns-read-int32)) + (list 'expire (dns-read-int32)) + (list 'minimum (dns-read-int32)))) + ((eq type 'SRV) + (list (list 'priority (dns-read-bytes 2)) + (list 'weight (dns-read-bytes 2)) + (list 'port (dns-read-bytes 2)) + (list 'target (dns-read-name buffer)))) + ((eq type 'MX) + (cons (dns-read-bytes 2) (dns-read-name buffer))) + ((or (eq type 'CNAME) (eq type 'NS) (eq type 'PTR)) + (dns-read-string-name string buffer)) + (t string)))) (goto-char point)))) (defun dns-parse-resolv-conf () @@ -377,48 +378,51 @@ If REVERSEP, look up an IP address." (if (not dns-servers) (message "No DNS server configuration found") - (mm-with-unibyte-buffer - (let ((process (condition-case () - (dns-make-network-process (car dns-servers)) - (error - (message "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) - (tcp-p (and (not (fboundp 'make-network-process)) - (not (featurep 'xemacs)))) - (step 100) - (times (* dns-timeout 1000)) - (id (random 65000))) - (when process - (process-send-string - process - (dns-write `((id ,id) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)) - tcp-p)) - (while (and (zerop (buffer-size)) - (> times 0)) - (sit-for (/ step 1000.0)) - (accept-process-output process 0 step) - (decf times step)) - (ignore-errors - (delete-process process)) - (when (and tcp-p - (>= (buffer-size) 2)) - (goto-char (point-min)) - (delete-region (point) (+ (point) 2))) - (when (and (>= (buffer-size) 2) - ;; We had a time-out. - (> times 0)) - (let ((result (dns-read (buffer-string)))) - (if fullp - result - (let ((answer (car (dns-get 'answers result)))) - (when (eq type (dns-get 'type answer)) - (if (eq type 'TXT) - (dns-get-txt-answer (dns-get 'answers result)) - (dns-get 'data answer)))))))))))) + (let (default-enable-multibyte-characters) + (with-temp-buffer + (let ((process (condition-case () + (dns-make-network-process (car dns-servers)) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) + (tcp-p (and (not (fboundp 'make-network-process)) + (not (featurep 'xemacs)))) + (step 100) + (times (* dns-timeout 1000)) + (id (random 65000))) + (when process + (process-send-string + process + (dns-write `((id ,id) + (opcode query) + (queries ((,name (type ,type)))) + (recursion-desired-p t)) + tcp-p)) + (while (and (zerop (buffer-size)) + (> times 0)) + (sit-for (/ step 1000.0)) + (accept-process-output process 0 step) + (setq times (- times step))) + (condition-case nil + (delete-process process) + (error nil)) + (when (and tcp-p + (>= (buffer-size) 2)) + (goto-char (point-min)) + (delete-region (point) (+ (point) 2))) + (when (and (>= (buffer-size) 2) + ;; We had a time-out. + (> times 0)) + (let ((result (dns-read (buffer-string)))) + (if fullp + result + (let ((answer (car (dns-get 'answers result)))) + (when (eq type (dns-get 'type answer)) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer))))))))))))) (provide 'dns) diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el index 58168778e3e..60a57711d2a 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el @@ -158,6 +158,11 @@ LOCATION is used as the address location for bbdb." (or state "") zip))) +;; External. +(declare-function bbdb-parse-phone-number "ext:bbdb-com" + (string &optional number-type)) +(declare-function bbdb-string-trim "ext:bbdb" (string)) + (defun eudc-bbdbify-phone (phone location) "Parse PHONE into a vector compatible with BBDB. PHONE is either a string supposedly containing a phone number or diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index 7e37d9d4123..ef1379eee52 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -103,6 +103,19 @@ eudc-bbdb-current-query) record))) +;; External. +(declare-function bbdb-phone-location "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-phone-string "ext:bbdb" (phone)) +(declare-function bbdb-record-phones "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-address-streets "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-address-city "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-address-state "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-address-zip "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-address-location "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-record-addresses "ext:bbdb" t) ; via bbdb-defstruct +(declare-function bbdb-records "ext:bbdb" + (&optional dont-check-disk already-in-db-buffer)) + (defun eudc-bbdb-extract-phones (record) (mapcar (function (lambda (phone) @@ -116,25 +129,24 @@ (defun eudc-bbdb-extract-addresses (record) (let (s c val) - (mapcar (function - (lambda (address) - (setq val (concat (unless (= 0 (length (setq s (bbdb-address-street1 address)))) - (concat s "\n")) - (unless (= 0 (length (setq s (bbdb-address-street2 address)))) - (concat s "\n")) - (unless (= 0 (length (setq s (bbdb-address-street3 address)))) - (concat s "\n")) - (progn - (setq c (bbdb-address-city address)) - (setq s (bbdb-address-state address)) - (if (and (> (length c) 0) (> (length s) 0)) - (concat c ", " s " ") - (concat c " "))) - (bbdb-address-zip-string address))) - (if eudc-bbdb-use-locations-as-attribute-names - (cons (intern (bbdb-address-location address)) val) - (cons 'addresses (concat (bbdb-address-location address) "\n" val))))) - (bbdb-record-addresses record)))) + (mapcar (lambda (address) + (setq c (bbdb-address-streets address)) + (dotimes (n 3) + (unless (zerop (length (setq s (nth n c)))) + (setq val (concat val s "\n")))) + (setq c (bbdb-address-city address) + s (bbdb-address-state address)) + (setq val (concat val + (if (and (> (length c) 0) (> (length s) 0)) + (concat c ", " s) + c) + " " + (bbdb-address-zip address))) + (if eudc-bbdb-use-locations-as-attribute-names + (cons (intern (bbdb-address-location address)) val) + (cons 'addresses (concat (bbdb-address-location address) + "\n" val)))) + (bbdb-record-addresses record)))) (defun eudc-bbdb-format-record-as-result (record) "Format the BBDB RECORD as a EUDC query result record. diff --git a/lisp/gnus/hmac-def.el b/lisp/net/hmac-def.el index 58491ec4f4a..bfff7282adf 100644 --- a/lisp/gnus/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -1,25 +1,25 @@ ;;; hmac-def.el --- A macro for defining HMAC functions. -;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2001, 2007 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: HMAC, RFC 2104 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or -;; (at your option) any later version. +;; GNU Emacs 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 3, or (at your option) +;; any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: diff --git a/lisp/gnus/hmac-md5.el b/lisp/net/hmac-md5.el index 21fc91992ad..186708446f0 100644 --- a/lisp/gnus/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,25 +1,25 @@ ;;; hmac-md5.el --- Compute HMAC-MD5. -;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2001, 2007 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: HMAC, RFC 2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or -;; (at your option) any later version. +;; GNU Emacs 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 3, or (at your option) +;; any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: diff --git a/lisp/gnus/imap.el b/lisp/net/imap.el index 7643ef4a53d..8e41c68720b 100644 --- a/lisp/gnus/imap.el +++ b/lisp/net/imap.el @@ -966,6 +966,13 @@ Returns t if login was successful, nil otherwise." (imap-capability nil buffer)) mecs)) +(declare-function sasl-find-mechanism "sasl" (mechanism)) +(declare-function sasl-mechanism-name "sasl" (mechanism)) +(declare-function sasl-make-client "sasl" (mechanism name service server)) +(declare-function sasl-next-step "sasl" (client step)) +(declare-function sasl-step-data "sasl" (step)) +(declare-function sasl-step-set-data "sasl" (step data)) + (defun imap-sasl-auth-p (buffer) (and (condition-case () (require 'sasl) @@ -1526,10 +1533,11 @@ or 'unseen. The IMAP command tag is returned." (imap-send-command (list "STATUS \"" (imap-utf7-encode mailbox) "\" " - (format "%s" - (if (listp items) - items - (list items))))))) + (upcase + (format "%s" + (if (listp items) + items + (list items)))))))) (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." @@ -2517,7 +2525,7 @@ Return nil if no complete line has arrived." (while (and (not (eq (char-after) ?\))) (or (forward-char) t) (looking-at "\\([A-Za-z]+\\) ")) - (let ((token (match-string 1))) + (let ((token (upcase (match-string 1)))) (goto-char (match-end 0)) (cond ((string= token "MESSAGES") (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index 8c4b0a08f51..da9182e7cdd 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -39,11 +39,6 @@ (if (fboundp 'point-at-eol) 'point-at-eol 'line-end-position)) -;; autoload encrypt - -(eval-and-compile - (autoload 'encrypt-find-model "encrypt") - (autoload 'encrypt-insert-file-contents "encrypt")) (defgroup netrc nil "Netrc configuration." @@ -60,13 +55,8 @@ (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force" "port")) - (encryption-model (encrypt-find-model file)) alist elem result pair) - - (if encryption-model - (encrypt-insert-file-contents file encryption-model) - (insert-file-contents file)) - + (insert-file-contents file) (goto-char (point-min)) ;; Go through the file, line by line. (while (not (eobp)) @@ -190,8 +180,7 @@ MODE can be \"login\" or \"password\", suitable for passing to (setq type (or type 'tcp)) (while (and (setq service (pop services)) (not (and (= number (cadr service)) - (eq type (caddr service))))) - ) + (eq type (car (cddr service))))))) (car service))) (defun netrc-find-service-number (name &optional type) @@ -200,8 +189,7 @@ MODE can be \"login\" or \"password\", suitable for passing to (setq type (or type 'tcp)) (while (and (setq service (pop services)) (not (and (string= name (car service)) - (eq type (caddr service))))) - ) + (eq type (car (cddr service))))))) (cadr service))) (provide 'netrc) diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el index 735d946346d..32d2c43f211 100644 --- a/lisp/net/newsticker.el +++ b/lisp/net/newsticker.el @@ -2600,6 +2600,9 @@ If URL is nil it is searched at point." (add-to-list 'newsticker-url-list (list name url nil nil nil) t) (customize-variable 'newsticker-url-list)) +;; External. +(declare-function w3m-toggle-inline-image "ext:w3m" (&optional force no-cache)) + (defun newsticker-w3m-show-inline-images () "Show inline images in visible text ranges. In-line images in invisible text ranges are hidden. This function @@ -4843,6 +4846,11 @@ The face is chosen according the values of NT-FACE and AGE." ;; ====================================================================== ;;; HTML rendering ;; ====================================================================== + +;; External. +(declare-function htmlr-reset "ext:htmlr" ()) +(declare-function htmlr-step "ext:htmlr" ()) + (defun newsticker-htmlr-render (pos1 pos2) ; "Replacement for `htmlr-render'. Renders the HTML code in the region POS1 to POS2 using htmlr." diff --git a/lisp/gnus/ntlm.el b/lisp/net/ntlm.el index edea2c3048a..126f6688f0d 100644 --- a/lisp/gnus/ntlm.el +++ b/lisp/net/ntlm.el @@ -1,23 +1,26 @@ ;;; ntlm.el --- NTLM (NT LanManager) authentication support -;; Copyright (C) 2001 Taro Kawagishi +;; Copyright (C) 2001, 2007 Free Software Foundation, Inc. + ;; Author: Taro Kawagishi <tarok@transpulse.org> ;; Keywords: NTLM, SASL ;; Version: 1.00 ;; Created: February 2001 -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) ;; any later version. -;; -;; This program is distributed in the hope that it will be useful, + +;; GNU Emacs 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. -;; + ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/gnus/sasl-cram.el b/lisp/net/sasl-cram.el index b8b1ced82ac..32f1e69f81f 100644 --- a/lisp/gnus/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -1,25 +1,25 @@ ;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, CRAM-MD5 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or (at -;; your option) any later version. +;; GNU Emacs 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 3, 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. +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/gnus/sasl-digest.el b/lisp/net/sasl-digest.el index c290c7524c8..6c544518e7f 100644 --- a/lisp/gnus/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -1,28 +1,30 @@ ;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, DIGEST-MD5 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or (at -;; your option) any later version. +;; GNU Emacs 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 3, 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. +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. +;;; Commentary: + ;; This program is implemented from draft-leach-digest-sasl-05.txt. ;; ;; It is caller's responsibility to base64-decode challenges and diff --git a/lisp/gnus/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index 784b373c056..cd8304db70a 100644 --- a/lisp/gnus/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -1,24 +1,26 @@ ;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. ;; Author: Taro Kawagishi <tarok@transpulse.org> ;; Keywords: SASL, NTLM ;; Version: 1.00 ;; Created: February 2001 -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) ;; any later version. -;; -;; This program is distributed in the hope that it will be useful, + +;; GNU Emacs 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. -;; + ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/gnus/sasl.el b/lisp/net/sasl.el index d730dddcb20..9118d288da4 100644 --- a/lisp/gnus/sasl.el +++ b/lisp/net/sasl.el @@ -1,24 +1,24 @@ ;;; sasl.el --- SASL client framework -;; Copyright (C) 2000 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Keywords: SASL -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or (at -;; your option) any later version. +;; GNU Emacs 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 3, 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. +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. diff --git a/lisp/net/socks.el b/lisp/net/socks.el index fd8e7ec59f2..b06c9db0396 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -335,6 +335,19 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ) ) +(declare-function socks-original-open-network-stream "socks") ; fset + +(defvar socks-override-functions nil + "*Whether to overwrite the open-network-stream function with the SOCKSified +version.") + +(if (fboundp 'socks-original-open-network-stream) + nil ; Do nothing, we've been here already + (defalias 'socks-original-open-network-stream + (symbol-function 'open-network-stream)) + (if socks-override-functions + (defalias 'open-network-stream 'socks-open-network-stream))) + (defun socks-open-connection (server-info) (interactive) (save-excursion @@ -473,17 +486,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (setq noproxy (cdr noproxy))) route)) -(defvar socks-override-functions nil - "*Whether to overwrite the open-network-stream function with the SOCKSified -version.") - -(if (fboundp 'socks-original-open-network-stream) - nil ; Do nothing, we've been here already - (defalias 'socks-original-open-network-stream - (symbol-function 'open-network-stream)) - (if socks-override-functions - (defalias 'open-network-stream 'socks-open-network-stream))) - (defvar socks-services-file "/etc/services") (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal)) (defvar socks-udp-services (make-hash-table :size 13 :test 'equal)) diff --git a/lisp/net/tls.el b/lisp/net/tls.el index 104cb991254..594212923c2 100644 --- a/lisp/net/tls.el +++ b/lisp/net/tls.el @@ -85,26 +85,93 @@ and `gnutls-cli' (version 2.0.1) output." Each entry in the list is tried until a connection is successful. %h is replaced with server hostname, %p with port to connect to. The program should read input on stdin and write output to -stdout. Also see `tls-success' for what the program should output -after successful negotiation." - :type '(repeat string) +stdout. + +See `tls-checktrust' on how to check trusted root certs. + +Also see `tls-success' for what the program should output after +successful negotiation." + :type + '(choice + (list :tag "Choose commands" + :value + ("gnutls-cli -p %p %h" + "gnutls-cli -p %p %h --protocols ssl3" + "openssl s_client -connect %h:%p -no_ssl2") + (set :inline t + ;; FIXME: add brief `:tag "..."' descriptions. + ;; (repeat :inline t :tag "Other" (string)) + ;; See `tls-checktrust': + (const "gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h") + (const "gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3") + (const "openssl s_client -connect %h:%p -CAfile /etc/ssl/certs/ca-certificates.crt -no_ssl2") + ;; No trust check: + (const "gnutls-cli -p %p %h") + (const "gnutls-cli -p %p %h --protocols ssl3") + (const "openssl s_client -connect %h:%p -no_ssl2")) + (repeat :inline t :tag "Other" (string))) + (const :tag "Default list of commands" + ("gnutls-cli -p %p %h" + "gnutls-cli -p %p %h --protocols ssl3" + "openssl s_client -connect %h:%p -no_ssl2")) + (list :tag "List of commands" + (repeat :tag "Command" (string)))) :version "22.1" :group 'tls) (defcustom tls-process-connection-type nil - "*Value for `process-connection-type' to use when starting TLS process." + "Value for `process-connection-type' to use when starting TLS process." :version "22.1" :type 'boolean :group 'tls) (defcustom tls-success "- Handshake was completed\\|SSL handshake has read " - "*Regular expression indicating completed TLS handshakes. + "Regular expression indicating completed TLS handshakes. The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's \"openssl s_client\" outputs." :version "22.1" :type 'regexp :group 'tls) +(defcustom tls-checktrust nil + "Indicate if certificates should be checked against trusted root certs. +If this is `ask', the user can decide whether to accept an +untrusted certificate. You may have to adapt `tls-program' in +order to make this feature work properly, i.e., to ensure that +the external program knows about the root certificates you +consider trustworthy, e.g.: + +\(setq tls-program + '(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\" + \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3\" + \"openssl s_client -connect %h:%p -CAfile /etc/ssl/certs/ca-certificates.crt -no_ssl2\"))" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :version "23.0" ;; No Gnus + :group 'tls) + +(defcustom tls-untrusted + "- Peer's certificate is NOT trusted\\|Verify return code: \\([^0] \\|.[^ ]\\)" + "Regular expression indicating failure of TLS certificate verification. +The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's +\"openssl s_client\" return in the event of unsuccessful +verification." + :type 'regexp + :version "23.0" ;; No Gnus + :group 'tls) + +(defcustom tls-hostmismatch + "# The hostname in the certificate does NOT match" + "Regular expression indicating a host name mismatch in certificate. +When the host name specified in the certificate doesn't match the +name of the host you are connecting to, gnutls-cli issues a +warning to this effect. There is no such feature in openssl. Set +this to nil if you want to ignore host name mismatches." + :type 'regexp + :version "23.0" ;; No Gnus + :group 'tls) + (defcustom tls-certtool-program (executable-find "certtool") "Name of GnuTLS certtool. Used by `tls-certificate-information'." @@ -141,7 +208,7 @@ Returns a subprocess-object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. Args are NAME BUFFER HOST PORT. NAME is name for process. It is modified if necessary to make it unique. -BUFFER is the buffer (or buffer-name) to associate with the process. +BUFFER is the buffer (or buffer name) to associate with the process. Process output goes at end of that buffer, unless you specify an output stream or filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated @@ -177,25 +244,31 @@ Fourth arg PORT is an integer specifying a port to connect to." (sit-for 1))) (message "Opening TLS connection with `%s'...%s" cmd (if done "done" "failed")) - (if (not done) - (delete-process process) - ;; advance point to after all informational messages that - ;; `openssl s_client' and `gnutls' print - (let ((start-of-data nil)) - (while - (not (setq start-of-data - ;; the string matching `tls-end-of-info' - ;; might come in separate chunks from - ;; `accept-process-output', so start the - ;; search where `tls-success' ended - (save-excursion - (if (re-search-forward tls-end-of-info nil t) - (match-end 0))))) - (accept-process-output process 1)) - (if start-of-data - ;; move point to start of client data - (goto-char start-of-data))) - (setq done process)))) + (if done + (setq done process) + (delete-process process)))) + (when done + (save-excursion + (set-buffer buffer) + (when + (or + (and tls-checktrust + (progn + (goto-char (point-min)) + (re-search-forward tls-untrusted nil t)) + (or + (and (not (eq tls-checktrust 'ask)) + (message "The certificate presented by `%s' is NOT trusted." host)) + (not (yes-or-no-p + (format "The certificate presented by `%s' is NOT trusted. Accept anyway? " host))))) + (and tls-hostmismatch + (progn + (goto-char (point-min)) + (re-search-forward tls-hostmismatch nil t)) + (not (yes-or-no-p + (format "Host name in certificate doesn't match `%s'. Connect anyway? " host))))) + (setq done nil) + (delete-process process)))) (message "Opening TLS connection to `%s'...%s" host (if done "done" "failed"))) (when use-temp-buffer diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index a8b6bca44f2..c4edd2f3fa4 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -152,6 +152,7 @@ pass to the OPERATION." (aset v 0 tramp-ftp-method) (tramp-set-connection-property v "started" t)) nil)) + ;; If the second argument of `copy-file' or `rename-file' is a ;; remote file name but via FTP, ange-ftp doesn't check this. ;; We must copy it locally first, because there is no place in @@ -163,8 +164,16 @@ pass to the OPERATION." (newname (cadr args)) (tmpfile (tramp-compat-make-temp-file filename)) (args (cddr args))) - (apply operation filename tmpfile args) - (rename-file tmpfile newname (car args)))) + ;; We must set `ok-if-already-exists' to t in the first + ;; step, because the temp file has been created already. + (if (eq operation 'copy-file) + (apply operation filename tmpfile t (cdr args)) + (apply operation filename tmpfile t)) + (unwind-protect + (rename-file tmpfile newname (car args)) + ;; Cleanup. + (ignore-errors (delete-file tmpfile))))) + ;; Normally, the handlers must be discarded. (t (let* ((inhibit-file-name-handlers (list 'tramp-file-name-handler diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 93fdea9ab27..95959b15a7c 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -83,7 +83,8 @@ ;; be mandatory (if (featurep 'xemacs) (load "password" 'noerror) - (require 'password nil 'noerror)) ;from No Gnus, also in tar ball + (or (require 'password-cache nil 'noerror) + (require 'password nil 'noerror))) ; from No Gnus, also in tar ball (require 'shell) (require 'advice) @@ -912,14 +913,6 @@ directories for POSIX compatible commands." (const :tag "Default Directories" tramp-default-remote-path) (string :tag "Directory")))) -(defcustom tramp-terminal-type "dumb" - "*Value of TERM environment variable for logging in to remote host. -Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init -files conditionalize this setup based on the TERM environment variable." - :group 'tramp - :type 'string) - (defcustom tramp-remote-process-environment `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_TIME=C" ,(concat "TERM=" tramp-terminal-type) @@ -1425,6 +1418,18 @@ opening a connection to a remote host." :group 'tramp :type '(choice (const nil) (const t) (const pty))) +(defcustom tramp-completion-reread-directory-timeout 10 + "Defines seconds since last remote command before rereading a directory. +A remote directory might have changed its contents. In order to +make it visible during file name completion in the minibuffer, +Tramp flushes its cache and rereads the directory contents when +more than `tramp-completion-reread-directory-timeout' seconds +have been gone since last remote command execution. A value of 0 +would require an immediate reread during filename completion, nil +means to use always cached values for the directory contents." + :group 'tramp + :type '(choice (const nil) integer)) + ;;; Internal Variables: (defvar tramp-end-of-output @@ -2807,6 +2812,16 @@ and gid of the corresponding user is taken. Both parameters must be integers." "Like `file-name-all-completions' for Tramp files." (unless (save-match-data (string-match "/" filename)) (with-parsed-tramp-file-name (expand-file-name directory) nil + ;; Flush the directory cache. There could be changed directory + ;; contents. + (when (and (integerp tramp-completion-reread-directory-timeout) + (> (tramp-time-diff + (current-time) + (tramp-get-file-property + v localname "last-completion" '(0 0 0))) + tramp-completion-reread-directory-timeout)) + (tramp-flush-file-property v localname)) + (all-completions filename (mapcar @@ -2838,6 +2853,8 @@ and gid of the corresponding user is taken. Both parameters must be integers." (point) (tramp-compat-line-end-position)) result))) + (tramp-set-file-property + v localname "last-completion" (current-time)) result))))))) ;; The following isn't needed for Emacs 20 but for 19.34? @@ -4323,7 +4340,7 @@ ARGS are the arguments OPERATION has been called with." ; BUF ((member operation (list 'set-visited-file-modtime 'verify-visited-file-modtime - ; Emacs 22 only + ; since Emacs 22 only 'make-auto-save-file-name ; XEmacs only 'backup-buffer)) @@ -5603,30 +5620,49 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." "Set up an interactive shell. Mainly sets the prompt and the echo correctly. PROC is the shell process to set up. VEC specifies the connection." - ;; It is useful to set the prompt in the following command because - ;; some people have a setting for $PS1 which /bin/sh doesn't know - ;; about and thus /bin/sh will display a strange prompt. For - ;; example, if $PS1 has "${CWD}" in the value, then ksh will display - ;; the current working directory but /bin/sh will display a dollar - ;; sign. The following command line sets $PS1 to a sane value, and - ;; works under Bourne-ish shells as well as csh-like shells. Daniel - ;; Pittman reports that the unusual positioning of the single quotes - ;; makes it work under `rc', too. We also unset the variable $ENV - ;; because that is read by some sh implementations (eg, bash when - ;; called as sh) on startup; this way, we avoid the startup file - ;; clobbering $PS1. $PROMP_COMMAND is another way to set the prompt - ;; in /bin/bash, it must be discarded as well. (let ((tramp-end-of-output "$ ")) + ;; It is useful to set the prompt in the following command because + ;; some people have a setting for $PS1 which /bin/sh doesn't know + ;; about and thus /bin/sh will display a strange prompt. For + ;; example, if $PS1 has "${CWD}" in the value, then ksh will + ;; display the current working directory but /bin/sh will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. Daniel Pittman reports that the unusual positioning of + ;; the single quotes makes it work under `rc', too. We also unset + ;; the variable $ENV because that is read by some sh + ;; implementations (eg, bash when called as sh) on startup; this + ;; way, we avoid the startup file clobbering $PS1. $PROMP_COMMAND + ;; is another way to set the prompt in /bin/bash, it must be + ;; discarded as well. (tramp-send-command vec (format "exec env 'ENV=' 'PROMPT_COMMAND=' 'PS1=$ ' PS2='' PS3='' %s" (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh)) - t)) + t) + + ;; Disable echo. + (tramp-message vec 5 "Setting up remote shell environment") + (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) + ;; Check whether the echo has really been disabled. Some + ;; implementations, like busybox of embedded GNU/Linux, don't + ;; support disabling. + (tramp-send-command vec "echo foo" t) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (when (looking-at "echo foo") + (tramp-set-connection-property proc "remote-echo" t) + (tramp-message vec 5 "Remote echo still on. Ok.") + ;; Make sure backspaces and their echo are enabled and no line + ;; width magic interferes with them. + (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) + (tramp-message vec 5 "Setting shell prompt") - ;; Douglas Gray Stephens <DGrayStephens@slb.com> says that we must - ;; use "\n" here, not tramp-rsh-end-of-line. + ;; We can set $PS1 to `tramp-end-of-output' only when the echo has + ;; been disabled. Otherwise, the echo of the command would be + ;; regarded as prompt already. (tramp-send-command vec (format "PROMPT_COMMAND=''; PS1='%s%s%s'; PS2=''; PS3=''" @@ -5634,26 +5670,7 @@ process to set up. VEC specifies the connection." tramp-end-of-output tramp-rsh-end-of-line) t) - ;; If the connection buffer is not empty, the remote shell is - ;; echoing, and the prompt has been detected through the echoed - ;; command. We must reread for the real prompt. - (with-current-buffer (process-buffer proc) - (when (> (point-max) (point-min)) (tramp-wait-for-output proc))) - ;; Disable echo. - (tramp-message vec 5 "Setting up remote shell environment") - (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) - ;; Check whether the echo has really been disabled. Some - ;; implementations, like busybox of embedded GNU/Linux, don't - ;; support disabling. - (tramp-send-command vec "echo foo" t) - (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (when (looking-at "echo foo") - (tramp-set-connection-property vec "remote-echo" t) - (tramp-message vec 5 "Remote echo still on. Ok.") - ;; Make sure backspaces and their echo are enabled and no line - ;; width magic interferes with them. - (tramp-send-command vec "stty icanon erase ^H cols 32767" t))) + ;; Try to set up the coding system correctly. ;; CCC this can't be the right way to do it. Hm. (tramp-message vec 5 "Determining coding system") @@ -5685,11 +5702,30 @@ process to set up. VEC specifies the connection." ;; stty, instead. (tramp-send-command vec "stty -onlcr" t)))) (tramp-send-command vec "set +o vi +o emacs" t) - ;; Check whether the remote host suffers from buggy `send-process-string'. - ;; This is known for FreeBSD (see comment in `send_process', file process.c). - ;; I've tested sending 624 bytes successfully, sending 625 bytes failed. - ;; Emacs makes a hack when this host type is detected locally. It cannot - ;; handle remote hosts, though. + + ;; Check whether the output of "uname -sr" has been changed. If + ;; yes, this is a strong indication that we must expire all + ;; connection properties. + (tramp-message vec 5 "Checking system information") + (let ((old-uname (tramp-get-connection-property vec "uname" nil)) + (new-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) + (funcall (symbol-function 'tramp-cleanup-connection) vec) + (signal + 'quit + (list (format + "Connection reset, because remote host changed from `%s' to `%s'" + old-uname new-uname))))) + + ;; Check whether the remote host suffers from buggy + ;; `send-process-string'. This is known for FreeBSD (see comment in + ;; `send_process', file process.c). I've tested sending 624 bytes + ;; successfully, sending 625 bytes failed. Emacs makes a hack when + ;; this host type is detected locally. It cannot handle remote + ;; hosts, though. (with-connection-property proc "chunksize" (cond ((and (integerp tramp-chunksize) (> tramp-chunksize 0)) @@ -5698,12 +5734,12 @@ process to set up. VEC specifies the connection." (tramp-message vec 5 "Checking remote host type for `send-process-string' bug") (if (string-match - "^FreeBSD" - (with-connection-property vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))) + "^FreeBSD" (tramp-get-connection-property vec "uname" "")) 500 0)))) + ;; Set remote PATH variable. (tramp-set-remote-path vec) + ;; Search for a good shell before searching for a command which ;; checks if a file exists. This is done because Tramp wants to use ;; "test foo; echo $?" to check if various conditions hold, and @@ -5713,8 +5749,10 @@ process to set up. VEC specifies the connection." ;; with buggy /bin/sh implementations will have a working bash or ;; ksh. Whee... (tramp-find-shell vec) + ;; Disable unexpected output. (tramp-send-command vec "mesg n; biff n" t) + ;; Set the environment. (tramp-message vec 5 "Setting default environment") (let ((env (copy-sequence tramp-remote-process-environment)) @@ -6190,7 +6228,7 @@ is meant to be used from `tramp-maybe-open-connection' only. The function waits for output unless NOOUTPUT is set." (unless neveropen (tramp-maybe-open-connection vec)) (let ((p (tramp-get-connection-process vec))) - (when (tramp-get-connection-property vec "remote-echo" nil) + (when (tramp-get-connection-property p "remote-echo" nil) ;; We mark the command string that it can be erased in the output buffer. (tramp-set-connection-property p "check-remote-echo" t) (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) @@ -6958,6 +6996,7 @@ If the `tramp-methods' entry does not exist, return NIL." (let ((bfn (buffer-file-name))) (when (and (stringp bfn) (tramp-tramp-file-p bfn) + (buffer-modified-p) (stringp buffer-auto-save-file-name) (not (equal bfn buffer-auto-save-file-name))) (unless (file-exists-p buffer-auto-save-file-name) diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 2de4fa025fd..1841b51e305 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -969,9 +969,11 @@ INDENT indicates to put CS and CCS at the current indentation of the region rather than at left margin." ;;(assert (< beg end)) (let ((no-empty (not (or (eq comment-empty-lines t) - (and comment-empty-lines (zerop (length ce))))))) + (and comment-empty-lines (zerop (length ce)))))) + ce-sanitized) ;; Sanitize CE and CCE. (if (and (stringp ce) (string= "" ce)) (setq ce nil)) + (setq ce-sanitized ce) (if (and (stringp cce) (string= "" cce)) (setq cce nil)) ;; If CE is empty, multiline cannot be used. (unless ce (setq ccs nil cce nil)) @@ -988,7 +990,7 @@ the region rather than at left margin." (goto-char end) ;; If the end is not at the end of a line and the comment-end ;; is implicit (i.e. a newline), explicitly insert a newline. - (unless (or ce (eolp)) (insert "\n") (indent-according-to-mode)) + (unless (or ce-sanitized (eolp)) (insert "\n") (indent-according-to-mode)) (comment-with-narrowing beg end (let ((min-indent (point-max)) (max-indent 0)) diff --git a/lisp/nxml/.gitignore b/lisp/nxml/.gitignore new file mode 100644 index 00000000000..f18ed02a937 --- /dev/null +++ b/lisp/nxml/.gitignore @@ -0,0 +1,2 @@ +*.elc +subdirs.el diff --git a/lisp/nxml/TODO b/lisp/nxml/TODO new file mode 100644 index 00000000000..3e7d5012b66 --- /dev/null +++ b/lisp/nxml/TODO @@ -0,0 +1,468 @@ +* High priority + +** Command to insert an element template, including all required +attributes and child elements. When there's a choice of elements +possible, we could insert a comment, and put an overlay on that +comment that makes it behave like a button with a pop-up menu to +select the appropriate choice. + +** Command to tag a region. With a schema should complete using legal +tags, but should work without a schema as well. + +** Provide a way to conveniently rename an element. With a schema should +complete using legal tags, but should work without a schema as well. + +* Outlining + +** Implement C-c C-o C-q. + +** Install pre/post command hook for moving out of invisible section. + +** Put a modify hook on invisible sections that expands them. + +** Integrate dumb folding somehow. + +** An element should be able to be its own heading. + +** Optimize to avoid complete buffer scan on each command. + +** Make it work with HTML-style headings (i.e. level indicated by +name of heading element rather than depth of section nesting). + +** Recognize root element as a section provided it has a title, even +if it doesn't match section-element-name-regex. + +** Support for incremental search automatically making hidden text +visible. + +** Allow title to be an attribute. + +** Command that says to recognize the tag at point as a section/heading. + +** Explore better ways to determine when an element is a section +or a heading. + +** rng-next-error needs to either ignore invisible portion or reveal it +(maybe use isearch oriented text properties). + +** Errors within hidden section should be highlighted by underlining the +ellipsis. + +** Make indirect buffers work. + +** How should nxml-refresh outline recover from non well-formed tags? + +** Hide tags in title elements? + +** Use overlays instead of text properties for holding outline state? +Necessary for indirect buffers to work? + +** Allow an outline to go in the speedbar. + +** Split up outlining manual section into subsections. + +** More detail in the manual about each outlining command. + +** More menu entries for hiding/showing? + +** Indication of many lines have been hidden? + +* Locating schemas + +** Should rng-validate-mode give the user an opportunity to specify a +schema if there is currently none? Or should it at least give a hint +to the user how to specify a non-vacuous schema? + +** Support for adding new schemas to schema-locating files. Add +documentElement and namespace elements. + +** C-c C-w should be able to report current type id. + +** Implement doctypePublicId. + +** Implement typeIdBase. + +** Implement typeIdProcessingInstruction. + +** Support xml:base. + +** Implement group. + +** Find preferred prefix from schema-locating files. Get rid of +rng-preferred-prefix-alist. + +** Inserting document element with vacuous schema should complete using +document elements declared in schema locating files, and set schema +appropriately. + +** Add a ruleType attribute to the <include> element? + +** Allow processing instruction in prolog to contain the compact syntax +schema directly. + +** Use RDDL to locate a schema based on the namespace URI. + +** Should not prompt to add redundant association to schema locating +file. + +** Command to reload current schema. + +* Schema-sensitive features + +** Should filter dynamic markup possibilities using schema validity, by +adding hook to nxml-mode. + +** Dynamic markup word should (at least optionally) be able to look in +other buffers that are using nxml-mode. + +** Should clicking on Invalid move to next error if already on an error? + +** Take advantage of a:documentation. Needs change to schema format. + +** Provide feasible validation (as in Jing) toggle. + +** Save the validation state as a property on the error overlay to enable +more detailed diagnosis. + +** Provide an Error Summary buffer showing all the validation errors. + +** Pop-up menu. What is useful? Tag a region (should be greyed out if +the region is not balanced). Suggestions based on error messages. + +** Have configurable list of namespace URIs so that we can provide +namespace URI completion on extension elements or with schema-less +documents. + +** Allow validation to handle XInclude. + +** ID/IDREF support. + +* Completion + +** Make it work with icomplete. Only use a function to complete when +some of the possible names have undeclared namespaces. + +** How should C-return in mixed text work? + +** When there's a vacuous schema, C-return after < will insert the +end-tag. Is this a bug or a feature? + +** After completing start-tag, ensure we don't get unhelpful message +from validation + +** Syntax table for completion. + +** Should complete start-tag name with a space if namespace attributes +are required. + +** When completing start-tag name with no prefix and it doesn't match +should try to infer namespace from local name. + +** Should completion pay attention to characters after point? If so, +how? + +** When completing start-tag name, add required atts if only one required +attribute. + +** When completing attribute name, add attribute value if only one value +is possible. + +** After attribute-value completion, insert space after close delimiter +if more attributes are required. + +** Complete on enumerated data values in elements. + +** When in context that allows only elements, should get tag +completion without having to type < first. + +** When immediately after start-tag name, and name is valid and not +prefix of any other name, should C-return complete on attribute names? + +** When completing attributes, more consistent to ignore all attributes +after point. + +** Inserting attribute value completions needs to be sensitive to what +delimiter is used so that it quotes the correct character. + +** Complete on encoding-names in XML decl. + +** Complete namespace declarations by searching for all namespaces +mentioned in the schema. + +* Well-formed XML support + +** Deal better with Mule-UCS + +** Deal with UTF-8 BOM when reading. + +** Complete entity names. + +** Provide some support for entity names for MathML. + +** Command to repeat the last tag. + +** Support for changing between character references and characters. +Need to check that context is one in which character references are +allowed. xmltok prolog parsing will need to distinguish parameter +literals from other kinds of literal. + +** Provide a comment command to bind to M-; that works better than the +normal one. + +** Make indenting in a multi-line comment work. + +** Structure view. Separate buffer displaying element tree. Be able to +navigate from structure view to document and vice-versa. + +** Flash matching >. + +** Smart selection command that selects increasingly large syntactically +coherent chunks of XML. If point is in an attribute value, first +select complete value; then if command is repeated, select value plus +delimiters, then select attribute name as well, then complete +start-tag, then complete element, then enclosing element, etc. + +** ispell integration. + +** Block-level items in mixed content should be indented, e.g: + <para>This is list: + <ul> + <li>item</li> + +** Provide option to indent like this: + +** <para>This is a paragraph + occupying multiple lines.</para> + +** Option to add make a / that closes a start-tag electrically insert a +space for the XHTML guys. + +** C-M-q should work. + +* Datatypes + +** Figure out workaround for CJK characters with regexps. + +** Does category C contain Cn? + +** Do ENTITY datatype properly. + +* XML Parsing Library + +** Parameter entity parsing option, nil (never), t (always), +unless-standalone (unless standalone="yes" in XML declaration). + +** When a file is currently being edited, there should be an option to +use its buffer instead of the on-disk copy. + +* Handling all XML features + +** Provide better support for editing external general parsed entities. +Perhaps provide a way to force ignoring undefined entities; maybe turn +this on automatically with <?xml encoding=""?> (with no version +pseudo-att). + +** Handle internal general entity declarations containing elements. + +** Handle external general entity declarations. + +** Handle default attribute declarations in internal subset. + +** Handle parameter entities (including DTD). + +* RELAX NG + +** Do complete schema checking, at least optionally. + +** Detect include/external loops during schema parse. + +** Coding system detection for schemas. Should use utf-8/utf-16 per the +spec. But also need to allow encodings other than UTF-8/16 to support +CJK charsets that Emacs cannot represent in Unicode. + +* Catching XML errors + +** Check public identifiers. + +** Check default attribute values. + +* Performance + +** Explore whether overlay-recenter can cure overlays performance +problems. + +** Cache schemas. Need to have list of files and mtimes. + +** Make it possible to reduce rng-validate-chunk-size significantly, +perhaps to 500 bytes, without bad performance impact: don't do +redisplay on every chunk; pass continue functions on other uses of +rng-do-some-validation. + +** Cache after first tag. + +** Introduce a new name class that is a choice between names (so that +we can use member) + +** intern-choice should simplify after patterns with same 1st/2nd args + +** Large numbers of overlays slow things down dramatically. Represent +errors using text properties. This implies we cannot incrementally +keep track of the number of errors, in order to determine validity. +Instead, when validation completes, scan for any characters with an +error text property; this seems to be fast enough even with large +buffers. Problem with error at end of buffer, where there's no +character; need special variable for this. Need to merge face from +font-lock with the error face: use :inherit attribute with list of two +faces. How do we avoid making rng-valid depend on nxml-mode? + +* Error recovery + +** Don't stop at newline in looking for close of start-tag. + +** Use indentation to guide recovery from mismatched end-tags + +** Don't keep parsing when currently not well-formed but previously +well-formed + +** Try to recover from a bad start-tag by popping an open element if +there was a mismatched end-tag unaccounted for. + +** Try to recover from a bad start-tag open on the hypothesis that there +was an error in the namespace URI. + +** Better recovery from ill-formed XML declarations. + +* Useability improvements + +** Should print a "Parsing..." message during long movements. + +** Provide better position for reference to undefined pattern error. + +** Put Well-formed in the mode-line when validating against any-content. + +** Trim marking of illegal data for leading and trailing whitespace. + +** Show Invalid status as soon as we are sure it's invalid, rather than +waiting for everything to be completely up to date. + +** When narrowed, Valid or Invalid status should probably consider only +validity of narrowed region. + +* Bug fixes + +** Need to give an error for a document like: <foo/><![CDATA[ ]]> + +** Make nxml-forward-balanced-item work better for the prolog. + +** Make filling and indenting comments work in the prolog. + +** Should delete RNC Input buffers. + +** Figure out what regex use for NCName and use it consistently, + +** Should have not-well-formed tokens in ref. + +** Require version in XML declaration? Probably not because prevents +use for external parsed entities. At least forbid standalone +without version. + +** Reject schema that compiles to rng-not-allowed-ipattern. + +** Move point backwards on schema parse error so that it's on the right token. + +* Internal + +** Use rng-quote-string consistently. + +** Use parsing library for XML to texinfo conversion. + +** Rename xmltok.el to nxml-token.el. Use nxml-t- prefix instead of +xmltok-. Change nxml-t-type to nxml-t-token-type, nxml-t-start to +nxml-t-token-start. + +** Can we set fill-prefix to nil and rely on indenting? + +** xmltok should make available replacement text of entities containing +elements + +** In rng-valid, instead of using modification-hooks and +insert-behind-hooks on dependent overlays, use same technique as +nxml-mode. + +** Port to XEmacs. Issues include: Unicode (XEmacs seems to be based on +Mule-UCS); overlays/text properties vs extents; absence of +fontification-functions hook. + +* Fontification + +** Allow face to depend on element qname, attribute qname, attribute +value. Use list with pairs of (R . F), where R specifies regexps and +F specifies faces. How can this list be made to depend on the +document type? + +* Other + +** Support RELAX NG XML syntax (use XML parsing library). + +** Support W3C XML Schema (use XML parsing library). + +** Command to infer schema from current document (like trang). + +* Schemas + +** XSLT schema should take advantage of RELAX NG to express cooccurrence +constraints on attributes (e.g. xsl:template). + +* Documentation + +** Move material from README to manual. + +** Document encodings. + +* Notes + +** How can we allow an error to be displayed on a different token from +where it is detected? In particular, for a missing closing ">" we +will need to display it at the beginning of the following token. At +the moment, when we parse the following token the error overlay will +get cleared. + +** How should rng-goto-next-error deal with narrowing? + +** Perhaps should merge errors having same start position even if they +have different ends. + +** How to handle surrogates? One possibility is to be compatible with +utf8.e: represent as sequence of 4 chars. But utf-16 is incompatible +with this. + +** Should we distinguish well-formedness errors from invalidity errors? +(I think not: we may want to recover from a bad start-tag by implying +an end-tag.) + +** Seems to be a bug with Emacs, where a mouse movement that causes +help-echo text to appear counts as pending input but does not cause +idle timer to be restarted. + +** Use XML to represent this file. + +** I had a TODO which said simply "split-string". What did I mean? + +** Investigate performance on large files all on one line. + +* CVS emacs issues + +** Take advantage of UTF-8 CJK support. + +** Supply a next-error-function. + +** Investigate this NEWS item "Emacs now tries to set up buffer coding +systems for HTML/XML files automatically." + +** Take advantage of the pointer text property. + +** Leverage char-displayable-p. + +Local variables: +mode: outline +end: diff --git a/lisp/nxml/nxml-enc.el b/lisp/nxml/nxml-enc.el new file mode 100644 index 00000000000..115db17ad70 --- /dev/null +++ b/lisp/nxml/nxml-enc.el @@ -0,0 +1,173 @@ +;;; nxml-enc.el --- XML encoding auto-detection + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; User entry points are nxml-start-auto-coding and +;; nxml-stop-auto-coding. This is separate from nxml-mode, because +;; this cannot be autoloaded. It may use +;; `xmltok-get-declared-encoding-position' which can be autoloaded. +;; It's separate from rng-auto.el so it can be byte-compiled, and +;; because it provides independent, useful functionality. + +;;; Code: + +(defvar nxml-file-name-ignore-case + (memq system-type '(vax-vms windows-nt))) + +(defvar nxml-cached-file-name-auto-coding-regexp nil) +(defvar nxml-cached-auto-mode-alist nil) + +(defun nxml-file-name-auto-coding-regexp () + "Return regexp for filenames for which XML auto-coding should be done." + (if (eq auto-mode-alist nxml-cached-auto-mode-alist) + nxml-cached-file-name-auto-coding-regexp + (let ((alist auto-mode-alist) + (case-fold-search nxml-file-name-ignore-case) + regexps) + (setq nxml-cached-auto-mode-alist alist) + (while alist + (when (eq (cdar alist) 'nxml-mode) + (setq regexps (cons (caar alist) regexps))) + (setq alist (cdr alist))) + (setq nxml-cached-file-name-auto-coding-regexp + (if (null (cdr regexps)) + (car regexps) + (mapconcat (lambda (r) + (concat "\\(?:" r "\\)")) + regexps + "\\|")))))) + +(defvar nxml-non-xml-set-auto-coding-function nil + "The function that `set-auto-coding-function' should call for non-XML files.") +(defun nxml-set-auto-coding (file-name size) + (if (let ((case-fold-search nxml-file-name-ignore-case) + (regexp (nxml-file-name-auto-coding-regexp))) + (and regexp + (string-match regexp file-name))) + (nxml-set-xml-coding file-name size) + (and nxml-non-xml-set-auto-coding-function + (funcall nxml-non-xml-set-auto-coding-function file-name size)))) + +(defun nxml-set-xml-coding (file-name size) + "Function to use as `set-auto-coding-function' when file is known to be XML." + (nxml-detect-coding-system (+ (point) (min size 1024)))) + +(declare-function xmltok-get-declared-encoding-position "xmltok" + (&optional limit)) ; autoloaded + +(defun nxml-detect-coding-system (limit) + (if (< limit (+ (point) 2)) + (if (eq (char-after) 0) 'no-conversion 'utf-8) + (let ((first-two-chars (list (char-after) + (char-after (1+ (point)))))) + (cond ((equal first-two-chars '(#xFE #xFF)) + (and (coding-system-p 'utf-16-be) 'utf-16-be)) + ((equal first-two-chars '(#xFF #xFE)) + (and (coding-system-p 'utf-16-le) 'utf-16-le)) + ((memq 0 first-two-chars) + ;; Certainly not well-formed XML; + ;; perhaps UTF-16 without BOM. + ;; In any case, we can't handle it. + ;; no-conversion gives the user a chance to fix it. + 'no-conversion) + ;; There are other things we might try here in the future + ;; eg UTF-8 BOM, UTF-16 with no BOM + ;; translate to EBCDIC + (t + (let ((enc-pos (xmltok-get-declared-encoding-position limit))) + (cond ((consp enc-pos) + (or (nxml-mime-charset-coding-system + (buffer-substring-no-properties (car enc-pos) + (cdr enc-pos))) + ;; We have an encoding whose name we don't recognize. + ;; What to do? + ;; raw-text seems the best bet: since we got + ;; the XML decl it must be a superset of ASCII, + ;; so we don't need to go to no-conversion + 'raw-text)) + (enc-pos 'utf-8) + ;; invalid XML declaration + (t nil)))))))) + +(defun nxml-mime-charset-coding-system (charset) + (let ((charset-sym (intern (downcase charset))) + (coding-systems (coding-system-list t)) + coding-system ret) + (while (and coding-systems (not ret)) + (setq coding-system (car coding-systems)) + (if (eq (coding-system-get coding-system 'mime-charset) + charset-sym) + (setq ret coding-system) + (setq coding-systems (cdr coding-systems)))) + ret)) + +(defun nxml-start-auto-coding () + "Do encoding auto-detection as specified in the XML standard. +Applied to any files that `auto-mode-alist' says should be handled by +`nxml-mode'." + (interactive) + (unless (eq set-auto-coding-function 'nxml-set-auto-coding) + (let ((inhibit-quit t)) + (setq nxml-non-xml-set-auto-coding-function set-auto-coding-function) + (setq set-auto-coding-function 'nxml-set-auto-coding)))) + +(defun nxml-stop-auto-coding () + "Stop doing encoding auto-detection as specified in the XML standard." + (interactive) + (when (eq set-auto-coding-function 'nxml-set-auto-coding) + (let ((inhibit-quit t)) + (setq set-auto-coding-function nxml-non-xml-set-auto-coding-function) + (setq nxml-non-xml-set-auto-coding-function nil)))) + +(unless (coding-system-p 'us-ascii) + (make-coding-system + ;; Unicode Emacs uses ?- last time I looked + 'us-ascii 2 ?- + "ISO 2022 based 7-bit encoding for ASCII (MIME:US-ASCII)" + '(ascii) + '((safe-charsets ascii) + (mime-charset . us-ascii)))) + +;; Emacs 21.3.50 makes us-ascii an alias for iso-safe without +;; giving it a mime-charset property. +(unless (coding-system-get 'us-ascii 'mime-charset) + (coding-system-put 'us-ascii 'mime-charset 'us-ascii)) + +;; Work around bug in Emacs 21.3 + +(when (and (coding-system-p 'utf-16-le) + (eq (coding-system-get 'utf-16-le 'pre-write-conversion) + 'utf-16-le-pre-write-conversion)) + (coding-system-put 'utf-16-le 'pre-write-conversion nil)) + +(when (and (coding-system-p 'utf-16-le) + (eq (coding-system-get 'utf-16-be 'pre-write-conversion) + 'utf-16-be-pre-write-conversion)) + (coding-system-put 'utf-16-be 'pre-write-conversion nil)) + +(provide 'nxml-enc) + +;; arch-tag: c2436247-78f3-418c-8069-85dc5335d083 +;;; nxml-enc.el ends here diff --git a/lisp/nxml/nxml-glyph.el b/lisp/nxml/nxml-glyph.el new file mode 100644 index 00000000000..47d7086f246 --- /dev/null +++ b/lisp/nxml/nxml-glyph.el @@ -0,0 +1,421 @@ +;;; nxml-glyph.el --- glyph-handling for nxml-mode + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; The entry point to this file is `nxml-glyph-display-string'. +;; The current implementation is heuristic due to a lack of +;; Emacs primitives necessary to implement it properly. The user +;; can tweak the heuristics using `nxml-glyph-set-hook'. + +;;; Code: + +(defconst nxml-ascii-glyph-set + [(#x0020 . #x007E)]) + +(defconst nxml-latin1-glyph-set + [(#x0020 . #x007E) + (#x00A0 . #x00FF)]) + +;; These were generated by using nxml-insert-target-repertoire-glyph-set +;; on the TARGET[123] files in +;; http://www.cl.cam.ac.uk/~mgk25/download/ucs-fonts.tar.gz + +(defconst nxml-misc-fixed-1-glyph-set + [(#x0020 . #x007E) + (#x00A0 . #x00FF) + (#x0100 . #x017F) + #x018F #x0192 + (#x0218 . #x021B) + #x0259 + (#x02C6 . #x02C7) + (#x02D8 . #x02DD) + (#x0374 . #x0375) + #x037A #x037E + (#x0384 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03CE) + (#x0401 . #x040C) + (#x040E . #x044F) + (#x0451 . #x045C) + (#x045E . #x045F) + (#x0490 . #x0491) + (#x05D0 . #x05EA) + (#x1E02 . #x1E03) + (#x1E0A . #x1E0B) + (#x1E1E . #x1E1F) + (#x1E40 . #x1E41) + (#x1E56 . #x1E57) + (#x1E60 . #x1E61) + (#x1E6A . #x1E6B) + (#x1E80 . #x1E85) + (#x1EF2 . #x1EF3) + (#x2010 . #x2022) + #x2026 #x2030 + (#x2039 . #x203A) + #x20AC #x2116 #x2122 #x2126 + (#x215B . #x215E) + (#x2190 . #x2193) + #x2260 + (#x2264 . #x2265) + (#x23BA . #x23BD) + (#x2409 . #x240D) + #x2424 #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524 #x252C #x2534 #x253C #x2592 #x25C6 #x266A #xFFFD] + "Glyph set for TARGET1 glyph repertoire of misc-fixed-* font. +This repertoire is supported for the bold and oblique fonts.") + +(defconst nxml-misc-fixed-2-glyph-set + [(#x0020 . #x007E) + (#x00A0 . #x00FF) + (#x0100 . #x017F) + #x018F #x0192 + (#x01FA . #x01FF) + (#x0218 . #x021B) + #x0259 + (#x02C6 . #x02C7) + #x02C9 + (#x02D8 . #x02DD) + (#x0300 . #x0311) + (#x0374 . #x0375) + #x037A #x037E + (#x0384 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03CE) + #x03D1 + (#x03D5 . #x03D6) + #x03F1 + (#x0401 . #x040C) + (#x040E . #x044F) + (#x0451 . #x045C) + (#x045E . #x045F) + (#x0490 . #x0491) + (#x05D0 . #x05EA) + (#x1E02 . #x1E03) + (#x1E0A . #x1E0B) + (#x1E1E . #x1E1F) + (#x1E40 . #x1E41) + (#x1E56 . #x1E57) + (#x1E60 . #x1E61) + (#x1E6A . #x1E6B) + (#x1E80 . #x1E85) + (#x1EF2 . #x1EF3) + (#x2010 . #x2022) + #x2026 #x2030 + (#x2032 . #x2034) + (#x2039 . #x203A) + #x203C #x203E #x2044 + (#x2070 . #x2071) + (#x2074 . #x208E) + (#x20A3 . #x20A4) + #x20A7 #x20AC + (#x20D0 . #x20D7) + #x2102 #x2105 #x2113 + (#x2115 . #x2116) + #x211A #x211D #x2122 #x2124 #x2126 #x212E + (#x215B . #x215E) + (#x2190 . #x2195) + (#x21A4 . #x21A8) + (#x21D0 . #x21D5) + (#x2200 . #x2209) + (#x220B . #x220C) + #x220F + (#x2211 . #x2213) + #x2215 + (#x2218 . #x221A) + (#x221D . #x221F) + #x2221 + (#x2224 . #x222B) + #x222E #x223C #x2243 #x2245 + (#x2248 . #x2249) + #x2259 + (#x225F . #x2262) + (#x2264 . #x2265) + (#x226A . #x226B) + (#x2282 . #x228B) + #x2295 #x2297 + (#x22A4 . #x22A7) + (#x22C2 . #x22C3) + #x22C5 #x2300 #x2302 + (#x2308 . #x230B) + #x2310 + (#x2320 . #x2321) + (#x2329 . #x232A) + (#x23BA . #x23BD) + (#x2409 . #x240D) + #x2424 #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524 #x252C #x2534 #x253C + (#x254C . #x2573) + (#x2580 . #x25A1) + (#x25AA . #x25AC) + (#x25B2 . #x25B3) + #x25BA #x25BC #x25C4 #x25C6 + (#x25CA . #x25CB) + #x25CF + (#x25D8 . #x25D9) + #x25E6 + (#x263A . #x263C) + #x2640 #x2642 #x2660 #x2663 + (#x2665 . #x2666) + (#x266A . #x266B) + (#xFB01 . #xFB02) + #xFFFD] + "Glyph set for TARGET2 glyph repertoire of the misc-fixed-* fonts. +This repertoire is supported for the following fonts: +5x7.bdf 5x8.bdf 6x9.bdf 6x10.bdf 6x12.bdf 7x13.bdf 7x14.bdf clR6x12.bdf") + +(defconst nxml-misc-fixed-3-glyph-set + [(#x0020 . #x007E) + (#x00A0 . #x00FF) + (#x0100 . #x01FF) + (#x0200 . #x0220) + (#x0222 . #x0233) + (#x0250 . #x02AD) + (#x02B0 . #x02EE) + (#x0300 . #x034F) + (#x0360 . #x036F) + (#x0374 . #x0375) + #x037A #x037E + (#x0384 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03CE) + (#x03D0 . #x03F6) + (#x0400 . #x0486) + (#x0488 . #x04CE) + (#x04D0 . #x04F5) + (#x04F8 . #x04F9) + (#x0500 . #x050F) + (#x0531 . #x0556) + (#x0559 . #x055F) + (#x0561 . #x0587) + (#x0589 . #x058A) + (#x05B0 . #x05B9) + (#x05BB . #x05C4) + (#x05D0 . #x05EA) + (#x05F0 . #x05F4) + (#x10D0 . #x10F8) + #x10FB + (#x1E00 . #x1E9B) + (#x1EA0 . #x1EF9) + (#x1F00 . #x1F15) + (#x1F18 . #x1F1D) + (#x1F20 . #x1F45) + (#x1F48 . #x1F4D) + (#x1F50 . #x1F57) + #x1F59 #x1F5B #x1F5D + (#x1F5F . #x1F7D) + (#x1F80 . #x1FB4) + (#x1FB6 . #x1FC4) + (#x1FC6 . #x1FD3) + (#x1FD6 . #x1FDB) + (#x1FDD . #x1FEF) + (#x1FF2 . #x1FF4) + (#x1FF6 . #x1FFE) + (#x2000 . #x200A) + (#x2010 . #x2027) + (#x202F . #x2052) + #x2057 + (#x205F . #x2063) + (#x2070 . #x2071) + (#x2074 . #x208E) + (#x20A0 . #x20B1) + (#x20D0 . #x20EA) + (#x2100 . #x213A) + (#x213D . #x214B) + (#x2153 . #x2183) + (#x2190 . #x21FF) + (#x2200 . #x22FF) + (#x2300 . #x23CE) + (#x2400 . #x2426) + (#x2440 . #x244A) + (#x2500 . #x25FF) + (#x2600 . #x2613) + (#x2616 . #x2617) + (#x2619 . #x267D) + (#x2680 . #x2689) + (#x27E6 . #x27EB) + (#x27F5 . #x27FF) + (#x2A00 . #x2A06) + #x2A1D #x2A3F #x303F + (#xFB00 . #xFB06) + (#xFB13 . #xFB17) + (#xFB1D . #xFB36) + (#xFB38 . #xFB3C) + #xFB3E + (#xFB40 . #xFB41) + (#xFB43 . #xFB44) + (#xFB46 . #xFB4F) + (#xFE20 . #xFE23) + (#xFF61 . #xFF9F) + #xFFFD] + "Glyph set for TARGET3 glyph repertoire of the misc-fixed-* fonts. +This repertoire is supported for the following fonts: +6x13.bdf 8x13.bdf 9x15.bdf 9x18.bdf 10x20.bdf") + +(defconst nxml-wgl4-glyph-set + [(#x0020 . #x007E) + (#x00A0 . #x017F) + #x0192 + (#x01FA . #x01FF) + (#x02C6 . #x02C7) + #x02C9 + (#x02D8 . #x02DB) + #x02DD + (#x0384 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03CE) + (#x0401 . #x040C) + (#x040E . #x044F) + (#x0451 . #x045C) + (#x045E . #x045F) + (#x0490 . #x0491) + (#x1E80 . #x1E85) + (#x1EF2 . #x1EF3) + (#x2013 . #x2015) + (#x2017 . #x201E) + (#x2020 . #x2022) + #x2026 #x2030 + (#x2032 . #x2033) + (#x2039 . #x203A) + #x203C #x203E #x2044 #x207F + (#x20A3 . #x20A4) + #x20A7 #x20AC #x2105 #x2113 #x2116 #x2122 #x2126 #x212E + (#x215B . #x215E) + (#x2190 . #x2195) + #x21A8 #x2202 #x2206 #x220F + (#x2211 . #x2212) + #x2215 + (#x2219 . #x221A) + (#x221E . #x221F) + #x2229 #x222B #x2248 + (#x2260 . #x2261) + (#x2264 . #x2265) + #x2302 #x2310 + (#x2320 . #x2321) + #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524 + #x252C #x2534 #x253C + (#x2550 . #x256C) + #x2580 #x2584 #x2588 #x258C + (#x2590 . #x2593) + (#x25A0 . #x25A1) + (#x25AA . #x25AC) + #x25B2 #x25BA #x25BC #x25C4 + (#x25CA . #x25CB) + #x25CF + (#x25D8 . #x25D9) + #x25E6 + (#x263A . #x263C) + #x2640 #x2642 #x2660 #x2663 + (#x2665 . #x2666) + (#x266A . #x266B) + (#xFB01 . #xFB02)] + "Glyph set corresponding to Windows Glyph List 4.") + +(defvar nxml-glyph-set-hook nil + "*Hook for determining the set of glyphs in a face. +The hook will receive a single argument FACE. If it can determine the +set of glyphs representable by FACE, it must set the variable +`nxml-glyph-set' and return non-nil. Otherwise, it must return +nil. The hook will be run until success. The constants +`nxml-ascii-glyph-set', `nxml-latin1-glyph-set', +`nxml-misc-fixed-1-glyph-set', `nxml-misc-fixed-2-glyph-set', +`nxml-misc-fixed-3-glyph-set' and `nxml-wgl4-glyph-set' are predefined +for use by `nxml-glyph-set-hook'.") + +(defvar nxml-glyph-set nil + "Used by `nxml-glyph-set-hook' to return set of glyphs in a FACE. +This should dynamically bound by any function that runs +`nxml-glyph-set-hook'. The value must be either nil representing an +empty set or a vector. Each member of the vector is either a single +integer or a cons (FIRST . LAST) representing the range of integers +from FIRST to LAST. An integer represents a glyph with that Unicode +code-point. The vector must be ordered.") + +(defun nxml-x-set-glyph-set (face) + (setq nxml-glyph-set + (if (equal (face-attribute face :family) "misc-fixed") + nxml-misc-fixed-3-glyph-set + nxml-wgl4-glyph-set))) + +(defun nxml-w32-set-glyph-set (face) + (setq nxml-glyph-set nxml-wgl4-glyph-set)) + +(defun nxml-window-system-set-glyph-set (face) + (setq nxml-glyph-set nxml-latin1-glyph-set)) + +(defun nxml-terminal-set-glyph-set (face) + (setq nxml-glyph-set nxml-ascii-glyph-set)) + +(add-hook 'nxml-glyph-set-hook + (or (cdr (assq window-system + '((x . nxml-x-set-glyph-set) + (w32 . nxml-w32-set-glyph-set) + (nil . nxml-terminal-set-glyph-set)))) + 'nxml-window-system-set-glyph-set) + t) + +;;;###autoload +(defun nxml-glyph-display-string (n face) + "Return a string that can display a glyph for Unicode code-point N. +FACE gives the face that will be used for displaying the string. +Return nil if the face cannot display a glyph for N." + (let ((nxml-glyph-set nil)) + (run-hook-with-args-until-success 'nxml-glyph-set-hook face) + (and nxml-glyph-set + (nxml-glyph-set-contains-p n nxml-glyph-set) + (let ((ch (decode-char 'ucs n))) + (and ch (string ch)))))) + +(defun nxml-glyph-set-contains-p (n v) + (let ((start 0) + (end (length v)) + found mid mid-val mid-start-val mid-end-val) + (while (> end start) + (setq mid (+ start + (/ (- end start) 2))) + (setq mid-val (aref v mid)) + (if (consp mid-val) + (setq mid-start-val (car mid-val) + mid-end-val (cdr mid-val)) + (setq mid-start-val mid-val + mid-end-val mid-val)) + (cond ((and (<= mid-start-val n) + (<= n mid-end-val)) + (setq found t) + (setq start end)) + ((< n mid-start-val) + (setq end mid)) + (t + (setq start + (if (eq start mid) + end + mid))))) + found)) + +(provide 'nxml-glyph) + +;; arch-tag: 50985104-27c6-4241-8625-b11aa5685633 +;;; nxml-glyph.el ends here diff --git a/lisp/nxml/nxml-maint.el b/lisp/nxml/nxml-maint.el new file mode 100644 index 00000000000..7df2bc99f35 --- /dev/null +++ b/lisp/nxml/nxml-maint.el @@ -0,0 +1,109 @@ +;;; nxml-maint.el --- commands for maintainers of nxml-*.el + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +;;; Generating files with Unicode char names. + +(require 'nxml-uchnm) + +(defun nxml-create-unicode-char-name-sets (file) + "Generate files containing char names from Unicode standard." + (interactive "fUnicodeData file: ") + (mapc (lambda (block) + (let ((nameset (nxml-unicode-block-char-name-set (nth 0 block)))) + (save-excursion + (find-file (concat (get nameset 'nxml-char-name-set-file) + ".el")) + (erase-buffer) + (insert "(nxml-define-char-name-set '") + (prin1 nameset (current-buffer)) + (insert "\n '())\n") + (goto-char (- (point) 3))))) + nxml-unicode-blocks) + (save-excursion + (find-file file) + (goto-char (point-min)) + (let ((blocks nxml-unicode-blocks) + code name) + (while (re-search-forward "^\\([0-9A-F]+\\);\\([^<;][^;]*\\);" + nil + t) + (setq code (string-to-number (match-string 1) 16)) + (setq name (match-string 2)) + (while (and blocks + (> code (nth 2 (car blocks)))) + (setq blocks (cdr blocks))) + (when (and (<= (nth 1 (car blocks)) code) + (<= code (nth 2 (car blocks)))) + (save-excursion + (find-file (concat (get (nxml-unicode-block-char-name-set + (nth 0 (car blocks))) + 'nxml-char-name-set-file) + ".el")) + (insert "(") + (prin1 name (current-buffer)) + (insert (format " #x%04X)\n " code)))))))) + +;;; Parsing target repertoire files from ucs-fonts. +;; This is for converting the TARGET? files in +;; http://www.cl.cam.ac.uk/~mgk25/download/ucs-fonts.tar.gz +;; into a glyph set. + +(defun nxml-insert-target-repertoire-glyph-set (file var) + (interactive "fTarget file: \nSVariable name: ") + (let (lst head) + (save-excursion + (set-buffer (find-file-noselect file)) + (goto-char (point-min)) + (while (re-search-forward "^ *\\([a-FA-F0-9]\\{2\\}\\)[ \t]+" nil t) + (let ((row (match-string 1)) + (eol (save-excursion (end-of-line) (point)))) + (while (re-search-forward "\\([a-FA-F0-9]\\{2\\}\\)-\\([a-FA-F0-9]\\{2\\}\\)\\|\\([a-FA-F0-9]\\{2\\}\\)" eol t) + (setq lst + (cons (if (match-beginning 3) + (concat "#x" row (match-string 3)) + (concat "(#x" row (match-string 1) + " . #x" row (match-string 2) ")")) + lst)))))) + (setq lst (nreverse lst)) + (insert (format "(defconst %s\n [" var)) + (while lst + (setq head (car lst)) + (setq lst (cdr lst)) + (insert head) + (when (= (length head) 6) + (while (and lst (= (length (car lst)) 6)) + (insert " ") + (insert (car lst)) + (setq lst (cdr lst)))) + (when lst (insert "\n "))) + (insert "])\n"))) + +(provide 'nxml-maint) + +;; arch-tag: 2cff6b55-12af-47db-90da-a91f782f435a +;;; nxml-maint.el ends here diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el new file mode 100644 index 00000000000..42d16359fbc --- /dev/null +++ b/lisp/nxml/nxml-mode.el @@ -0,0 +1,2668 @@ +;;; nxml-mode.el --- a new XML mode + +;; Copyright (C) 2003, 2004, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; To use this include rng-auto.el in your .emacs. + +;; See nxml-rap.el for description of parsing strategy. + +;; The font locking here is independent of font-lock.el. We want to +;; do more sophisticated handling of changes and we want to use the +;; same xmltok rather than regexps for parsing so that we parse +;; consistently and correctly. + +;;; Code: + +(when (featurep 'mucs) + (error "nxml-mode is not compatible with Mule-UCS")) + +(require 'xmltok) +(require 'nxml-enc) +(require 'nxml-glyph) +(require 'nxml-util) +(require 'nxml-rap) +(require 'nxml-outln) + +;;; Customization + +(defgroup nxml nil + "New XML editing mode" + :group 'languages + :group 'wp) + +(defgroup nxml-highlighting-faces nil + "Faces for XML syntax highlighting." + :group 'nxml + :group 'font-lock-highlighting-faces) + +(defcustom nxml-syntax-highlight-flag t + "*Non-nil means nxml-mode should perform syntax highlighting." + :group 'nxml + :type 'boolean) + +(defcustom nxml-char-ref-display-glyph-flag t + "*Non-nil means display glyph following character reference. +The glyph is displayed in `nxml-glyph-face'. The hook +`nxml-glyph-set-hook' can be used to customize for which characters +glyphs are displayed." + :group 'nxml + :type 'boolean) + +(defcustom nxml-mode-hook nil + "Hook run by command `nxml-mode'." + :group 'nxml + :type 'hook) + +(defcustom nxml-sexp-element-flag nil + "*Non-nil means sexp commands treat an element as a single expression." + :group 'nxml + :type 'boolean) + +(defcustom nxml-slash-auto-complete-flag nil + "*Non-nil means typing a slash automatically completes the end-tag. +This is used by `nxml-electric-slash'." + :group 'nxml + :type 'boolean) + +(defcustom nxml-child-indent 2 + "*Indentation for the children of an element relative to the start-tag. +This only applies when the line or lines containing the start-tag contains +nothing else other than that start-tag." + :group 'nxml + :type 'integer) + +(defcustom nxml-attribute-indent 4 + "*Indentation for the attributes of an element relative to the start-tag. +This only applies when the first attribute of a tag starts a line. In other +cases, the first attribute on one line is indented the same as the first +attribute on the previous line." + :group 'nxml + :type 'integer) + +(defvar nxml-fontify-chunk-size 500) + +(defcustom nxml-bind-meta-tab-to-complete-flag (not window-system) + "*Non-nil means bind M-TAB in `nxml-mode-map' to `nxml-complete'. +C-return will be bound to `nxml-complete' in any case. +M-TAB gets swallowed by many window systems/managers, and +`documentation' will show M-TAB rather than C-return as the +binding `rng-complete' when both are bound. So it's better +to bind M-TAB only when it will work." + :group 'nxml + :set (lambda (sym flag) + (set-default sym flag) + (when (and (boundp 'nxml-mode-map) nxml-mode-map) + (define-key nxml-mode-map "\M-\t" (and flag 'nxml-complete)))) + :type 'boolean) + +(defcustom nxml-prefer-utf-16-to-utf-8-flag nil + "*Non-nil means prefer UTF-16 to UTF-8 when saving a buffer. +This is used only when a buffer does not contain an encoding declaration +and when its current `buffer-file-coding-system' specifies neither UTF-16 +nor UTF-8." + :group 'nxml + :type 'boolean) + +(defcustom nxml-prefer-utf-16-little-to-big-endian-flag (eq system-type + 'windows-nt) + "*Non-nil means prefer little-endian to big-endian byte-order for UTF-16. +This is used only for saving a buffer; when reading the byte-order is +auto-detected. It may be relevant both when there is no encoding declaration +and when the encoding declaration specifies `UTF-16'." + :group 'nxml + :type 'boolean) + +(defcustom nxml-default-buffer-file-coding-system nil + "*Default value for `buffer-file-coding-system' for a buffer for a new file. +Nil means use the default value of `buffer-file-coding-system' as normal. +A buffer's `buffer-file-coding-system' affects what \\[nxml-insert-xml-declaration] inserts." + :group 'nxml + :type 'coding-system) + +(defcustom nxml-auto-insert-xml-declaration-flag nil + "*Non-nil means automatically insert an XML declaration in a new file. +The XML declaration is inserted using `nxml-insert-xml-declaration'." + :group 'nxml + :type 'boolean) + +;; The following are the colors we use with a light background. +;; The two blues have the same hue but contrasting saturation/value. +;; The hue of the green is 120 degrees different from that of the +;; blue. The red used for highlighting errors is 120 degrees +;; different again. We use the light blue only for refs and +;; delimiters, since these are short (long stretches in a light color +;; would be too hard to read). The dark blue is closest to black +;; (which we use by default for text), so we use it for attribute +;; values, which are similar to text. + +(defconst nxml-light-blue-color "#9292C9") ; hue 240 +(defconst nxml-dark-blue-color "#3A3A7B") ; hue 240 +(defconst nxml-green-color "#257A25") ; hue 120 + +;; Similar principles apply with a dark background. However, +;; we switch green and blue, because darker blues are very hard to +;; read (for me anyway) on a dark background. + +(defconst nxml-sky-blue-color "#ACACFC") ; hue 240 +(defconst nxml-dark-green-color "#00AD00") ; hue 120 +(defconst nxml-light-green-color "#70F170") ; hue 120 + +(defface nxml-delimited-data-face + `((((class color) (background light)) (:foreground ,nxml-dark-blue-color)) + (((class color) (background dark)) (:foreground ,nxml-light-green-color))) + "Face used to highlight data enclosed between delimiters. +By default, this is inherited by `nxml-attribute-value-face' +and `nxml-processing-instruction-content-face'." + :group 'nxml-highlighting-faces) + +(defface nxml-name-face + `((((class color) (background light)) (:foreground ,nxml-green-color)) + (((class color) (background dark)) (:foreground ,nxml-sky-blue-color))) + "Face used to highlight various names. +This includes element and attribute names, processing +instruction targets and the CDATA keyword in a CDATA section. +This is not used directly, but only via inheritance by other faces." + :group 'nxml-highlighting-faces) + +(defface nxml-ref-face + `((((class color) (background light)) (:foreground ,nxml-light-blue-color)) + (((class color) (background dark)) (:foreground ,nxml-dark-green-color))) + "Face used to highlight character and entity references. +This is not used directly, but only via inheritance by other faces." + :group 'nxml-highlighting-faces) + +(defface nxml-delimiter-face + `((((class color) (background light)) (:foreground ,nxml-light-blue-color)) + (((class color) (background dark)) (:foreground ,nxml-dark-green-color)) + (t (:bold t))) + "Face used to highlight delimiters. +This is not used directly, but only via inheritance by other faces." + :group 'nxml-highlighting-faces) + +(defface nxml-text-face + nil + "Face used to highlight text." + :group 'nxml-highlighting-faces) + +(defface nxml-comment-content-face + '((t (:italic t))) + "Face used to highlight the content of comments." + :group 'nxml-highlighting-faces) + +(defface nxml-comment-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of comments, i.e <!-- and -->." + :group 'nxml-highlighting-faces) + +(defface nxml-processing-instruction-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of processing instructions, i.e <? and ?>." + :group 'nxml-highlighting-faces) + +(defface nxml-processing-instruction-target-face + '((t (:inherit nxml-name-face))) + "Face used for the target of processing instructions." + :group 'nxml-highlighting-faces) + +(defface nxml-processing-instruction-content-face + '((t (:inherit nxml-delimited-data-face))) + "Face used for the content of processing instructions." + :group 'nxml-highlighting-faces) + +(defface nxml-cdata-section-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of CDATA sections, i.e <![, [, and ]]>." + :group 'nxml-highlighting-faces) + +(defface nxml-cdata-section-CDATA-face + '((t (:inherit nxml-name-face))) + "Face used for the CDATA keyword in CDATA sections." + :group 'nxml-highlighting-faces) + +(defface nxml-cdata-section-content-face + '((t (:inherit nxml-text-face))) + "Face used for the content of CDATA sections." + :group 'nxml-highlighting-faces) + +(defface nxml-char-ref-number-face + '((t (:inherit nxml-ref-face))) + "Face used for the number in character references. +This includes ths `x' in hex references." + :group 'nxml-highlighting-faces) + +(defface nxml-char-ref-delimiter-face + '((t (:inherit nxml-ref-face))) + "Face used for the delimiters of character references, i.e &# and ;." + :group 'nxml-highlighting-faces) + +(defface nxml-entity-ref-name-face + '((t (:inherit nxml-ref-face))) + "Face used for the entity name in general entity references." + :group 'nxml-highlighting-faces) + +(defface nxml-entity-ref-delimiter-face + '((t (:inherit nxml-ref-face))) + "Face used for the delimiters of entity references, i.e & and ;." + :group 'nxml-highlighting-faces) + +(defface nxml-tag-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the angle brackets delimiting tags. +`nxml-tag-slash-face' is used for slashes." + :group 'nxml-highlighting-faces) + +(defface nxml-tag-slash-face + '((t (:inherit nxml-name-face))) + "Face used for slashes in tags, both in end-tags and empty-elements." + :group 'nxml-highlighting-faces) + +(defface nxml-element-prefix-face + '((t (:inherit nxml-name-face))) + "Face used for the prefix of elements." + :group 'nxml-highlighting-faces) + +(defface nxml-element-colon-face + '((t (:inherit nxml-name-face))) + "Face used for the colon in element names." + :group 'nxml-highlighting-faces) + +(defface nxml-element-local-name-face + '((t (:inherit nxml-name-face))) + "Face used for the local name of elements." + :group 'nxml-highlighting-faces) + +(defface nxml-attribute-prefix-face + '((t (:inherit nxml-name-face))) + "Face used for the prefix of attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-attribute-colon-face + '((t (:inherit nxml-name-face))) + "Face used for the colon in attribute names." + :group 'nxml-highlighting-faces) + +(defface nxml-attribute-local-name-face + '((t (:inherit nxml-name-face))) + "Face used for the local name of attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-namespace-attribute-xmlns-face + '((t (:inherit nxml-name-face))) + "Face used for `xmlns' in namespace attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-namespace-attribute-colon-face + '((t (:inherit nxml-name-face))) + "Face used for the colon in namespace attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-namespace-attribute-prefix-face + '((t (:inherit nxml-name-face))) + "Face used for the prefix declared in namespace attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-attribute-value-face + '((t (:inherit nxml-delimited-data-face))) + "Face used for the value of attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-attribute-value-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of attribute values." + :group 'nxml-highlighting-faces) + +(defface nxml-namespace-attribute-value-face + '((t (:inherit nxml-attribute-value-face))) + "Face used for the value of namespace attributes." + :group 'nxml-highlighting-faces) + +(defface nxml-namespace-attribute-value-delimiter-face + '((t (:inherit nxml-attribute-value-delimiter-face))) + "Face used for the delimiters of namespace attribute values." + :group 'nxml-highlighting-faces) + +(defface nxml-prolog-literal-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of literals in the prolog." + :group 'nxml-highlighting-faces) + +(defface nxml-prolog-literal-content-face + '((t (:inherit nxml-delimited-data-face))) + "Face used for the content of literals in the prolog." + :group 'nxml-highlighting-faces) + +(defface nxml-prolog-keyword-face + '((t (:inherit nxml-name-face))) + "Face used for keywords in the prolog." + :group 'nxml-highlighting-faces) + +(defface nxml-markup-declaration-delimiter-face + '((t (:inherit nxml-delimiter-face))) + "Face used for the delimiters of markup declarations in the prolog. +The delimiters are <! and >." + :group 'nxml-highlighting-faces) + +(defface nxml-hash-face + '((t (:inherit nxml-name-face))) + "Face used for # before a name in the prolog." + :group 'nxml-highlighting-faces) + +(defface nxml-glyph-face + '((((type x)) + (:family + "misc-fixed" + :background + "light grey" + :foreground + "black" + :weight + normal + :slant + normal)) + (t + (:background + "light grey" + :foreground + "black" + :weight + normal + :slant + normal))) + "Face used for glyph for char references." + :group 'nxml-highlighting-faces) + +;;; Global variables + +;; This is initialized in rng-auto.el. +(defvar nxml-version nil + "*The version of nxml-mode that is being used.") + +(defvar nxml-prolog-regions nil + "List of regions in the prolog to be fontified. +See the function `xmltok-forward-prolog' for more information.") +(make-variable-buffer-local 'nxml-prolog-regions) + +(defvar nxml-last-fontify-end nil + "Position where fontification last ended. +Nil if the buffer changed since the last fontification.") +(make-variable-buffer-local 'nxml-last-fontify-end) + +(defvar nxml-degraded nil + "Non-nil if currently operating in degraded mode. +Degraded mode is enabled when an internal error is encountered in the +fontification or after-change functions.") +(make-variable-buffer-local 'nxml-degraded) + +(defvar nxml-completion-hook nil + "Hook run by `nxml-complete'. +This hook is run until success.") + +(defvar nxml-in-mixed-content-hook nil + "Hook to determine whether point is in mixed content. +The hook is called without arguments. It should return nil if it is +definitely not mixed; non-nil otherwise. The hook will be run until +one of the functions returns nil.") + +(defvar nxml-mixed-scan-distance 4000 + "Maximum distance from point to scan when checking for mixed content.") + +(defvar nxml-end-tag-indent-scan-distance 4000 + "Maximum distance from point to scan backwards when indenting end-tag.") + +(defvar nxml-char-ref-extra-display t + "Non-nil means display extra information for character references. +The extra information consists of a tooltip with the character name +and, if `nxml-char-ref-display-glyph-flag' is non-nil, a glyph +corresponding to the referenced character following the character +reference.") +(make-variable-buffer-local 'nxml-char-ref-extra-display) + +(defvar nxml-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\M-\C-u" 'nxml-backward-up-element) + (define-key map "\M-\C-d" 'nxml-down-element) + (define-key map "\M-\C-n" 'nxml-forward-element) + (define-key map "\M-\C-p" 'nxml-backward-element) + (define-key map "\M-{" 'nxml-backward-paragraph) + (define-key map "\M-}" 'nxml-forward-paragraph) + (define-key map "\M-h" 'nxml-mark-paragraph) + (define-key map "\C-c\C-f" 'nxml-finish-element) + (define-key map "\C-c\C-m" 'nxml-split-element) + (define-key map "\C-c\C-b" 'nxml-balanced-close-start-tag-block) + (define-key map "\C-c\C-i" 'nxml-balanced-close-start-tag-inline) + (define-key map "\C-c\C-x" 'nxml-insert-xml-declaration) + (define-key map "\C-c\C-d" 'nxml-dynamic-markup-word) + ;; u is for Unicode + (define-key map "\C-c\C-u" 'nxml-insert-named-char) + (define-key map "\C-c\C-o" nxml-outline-prefix-map) + (define-key map [S-mouse-2] 'nxml-mouse-hide-direct-text-content) + (define-key map "/" 'nxml-electric-slash) + (define-key map [C-return] 'nxml-complete) + (when nxml-bind-meta-tab-to-complete-flag + (define-key map "\M-\t" 'nxml-complete)) + map) + "Keymap for nxml-mode.") + +(defsubst nxml-set-face (start end face) + (when (and face (< start end)) + (put-text-property start end 'face face))) + +(defun nxml-clear-face (start end) + (remove-text-properties start end '(face nil)) + (nxml-clear-char-ref-extra-display start end)) + +(defsubst nxml-set-fontified (start end) + (put-text-property start end 'fontified t)) + +(defsubst nxml-clear-fontified (start end) + (remove-text-properties start end '(fontified nil))) + +;;;###autoload +(defun nxml-mode () + ;; We use C-c C-i instead of \\[nxml-balanced-close-start-tag-inline] + ;; because Emacs turns C-c C-i into C-c TAB which is hard to type and + ;; not mnemonic. + "Major mode for editing XML. + +Syntax highlighting is performed unless the variable +`nxml-syntax-highlight-flag' is nil. + +\\[nxml-finish-element] finishes the current element by inserting an end-tag. +C-c C-i closes a start-tag with `>' and then inserts a balancing end-tag +leaving point between the start-tag and end-tag. +\\[nxml-balanced-close-start-tag-block] is similar but for block rather than inline elements: +the start-tag, point, and end-tag are all left on separate lines. +If `nxml-slash-auto-complete-flag' is non-nil, then inserting a `</' +automatically inserts the rest of the end-tag. + +\\[nxml-complete] performs completion on the symbol preceding point. + +\\[nxml-dynamic-markup-word] uses the contents of the current buffer +to choose a tag to put around the word preceding point. + +Sections of the document can be displayed in outline form. The +variable `nxml-section-element-name-regexp' controls when an element +is recognized as a section. The same key sequences that change +visibility in outline mode are used except that they start with C-c C-o +instead of C-c. + +Validation is provided by the related minor-mode `rng-validate-mode'. +This also makes completion schema- and context- sensitive. Element +names, attribute names, attribute values and namespace URIs can all be +completed. By default, `rng-validate-mode' is automatically enabled by +`rng-nxml-mode-init' which is normally added to `nxml-mode-hook'. You +can toggle it using \\[rng-validate-mode]. + +\\[indent-for-tab-command] indents the current line appropriately. +This can be customized using the variable `nxml-child-indent' +and the variable `nxml-attribute-indent'. + +\\[nxml-insert-named-char] inserts a character reference using +the character's name (by default, the Unicode name). \\[universal-argument] \\[nxml-insert-named-char] +inserts the character directly. + +The Emacs commands that normally operate on balanced expressions will +operate on XML markup items. Thus \\[forward-sexp] will move forward +across one markup item; \\[backward-sexp] will move backward across +one markup item; \\[kill-sexp] will kill the following markup item; +\\[mark-sexp] will mark the following markup item. By default, each +tag each treated as a single markup item; to make the complete element +be treated as a single markup item, set the variable +`nxml-sexp-element-flag' to t. For more details, see the function +`nxml-forward-balanced-item'. + +\\[nxml-backward-up-element] and \\[nxml-down-element] move up and down the element structure. + +Many aspects this mode can be customized using +\\[customize-group] nxml RET." + (interactive) + (kill-all-local-variables) + (setq major-mode 'nxml-mode) + (setq mode-name "nXML") + ;; We'll determine the fill prefix ourselves + (make-local-variable 'adaptive-fill-mode) + (setq adaptive-fill-mode nil) + (make-local-variable 'forward-sexp-function) + (setq forward-sexp-function 'nxml-forward-balanced-item) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'nxml-indent-line) + (make-local-variable 'fill-paragraph-function) + (setq fill-paragraph-function 'nxml-do-fill-paragraph) + ;; Comment support + ;; This doesn't seem to work too well; + ;; I think we should probably roll our own nxml-comment-dwim function. + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'nxml-indent-line) + (make-local-variable 'comment-start) + (setq comment-start "<!--") + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "<!--[ \t\r\n]*") + (make-local-variable 'comment-end) + (setq comment-end "-->") + (make-local-variable 'comment-end-skip) + (setq comment-end-skip "[ \t\r\n]*-->") + (make-local-variable 'comment-line-break-function) + (setq comment-line-break-function 'nxml-newline-and-indent) + (use-local-map nxml-mode-map) + (save-excursion + (save-restriction + (widen) + (nxml-clear-dependent-regions (point-min) (point-max)) + (setq nxml-scan-end (copy-marker (point-min) nil)) + (nxml-with-unmodifying-text-property-changes + (when nxml-syntax-highlight-flag + (nxml-clear-fontified (point-min) (point-max))) + (nxml-clear-inside (point-min) (point-max)) + (nxml-with-invisible-motion + (nxml-scan-prolog))))) + (when nxml-syntax-highlight-flag + (add-hook 'fontification-functions 'nxml-fontify nil t)) + (add-hook 'after-change-functions 'nxml-after-change nil t) + (add-hook 'write-contents-hooks 'nxml-prepare-to-save) + (when (not (and (buffer-file-name) (file-exists-p (buffer-file-name)))) + (when (and nxml-default-buffer-file-coding-system + (not (local-variable-p 'buffer-file-coding-system))) + (setq buffer-file-coding-system nxml-default-buffer-file-coding-system)) + (when nxml-auto-insert-xml-declaration-flag + (nxml-insert-xml-declaration))) + (run-hooks 'nxml-mode-hook)) + +(defun nxml-degrade (context err) + (message "Internal nXML mode error in %s (%s), degrading" + context + (error-message-string err)) + (ding) + (setq nxml-degraded t) + (setq nxml-prolog-end 1) + (save-excursion + (save-restriction + (widen) + (nxml-with-unmodifying-text-property-changes + (nxml-clear-face (point-min) (point-max)) + (nxml-set-fontified (point-min) (point-max)) + (nxml-clear-inside (point-min) (point-max))) + (setq mode-name "nXML/degraded")))) + +;;; Change management + +(defun nxml-after-change (start end pre-change-length) + ;; Work around bug in insert-file-contents. + (when (> end (1+ (buffer-size))) + (setq start 1) + (setq end (1+ (buffer-size)))) + (unless nxml-degraded + (condition-case err + (save-excursion + (save-restriction + (widen) + (save-match-data + (nxml-with-invisible-motion + (nxml-with-unmodifying-text-property-changes + (nxml-after-change1 start end pre-change-length)))))) + (error + (nxml-degrade 'nxml-after-change err))))) + +(defun nxml-after-change1 (start end pre-change-length) + (setq nxml-last-fontify-end nil) + (let ((pre-change-end (+ start pre-change-length))) + (setq start + (nxml-adjust-start-for-dependent-regions start + end + pre-change-length)) + (when (<= start + ;; Add 2 so as to include the < and following char + ;; that start the instance, since changing these + ;; can change where the prolog ends. + (+ nxml-prolog-end 2)) + ;; end must be extended to at least the end of the old prolog + (when (< pre-change-end nxml-prolog-end) + (setq end + ;; don't let end get out of range even if pre-change-length + ;; is bogus + (min (point-max) + (+ end (- nxml-prolog-end pre-change-end))))) + (nxml-scan-prolog))) + (cond ((<= end nxml-prolog-end) + (setq end nxml-prolog-end) + (goto-char start) + ;; This is so that Emacs redisplay works + (setq start (line-beginning-position))) + ((and (<= start nxml-scan-end) + (> start (point-min)) + (nxml-get-inside (1- start))) + ;; The closing delimiter might have been removed. + ;; So we may need to redisplay from the beginning + ;; of the token. + (goto-char (1- start)) + (nxml-move-outside-backwards) + ;; This is so that Emacs redisplay works + (setq start (line-beginning-position)) + (setq end (max (nxml-scan-after-change (point) end) + end))) + (t + (goto-char start) + ;; This is both for redisplay and to move back + ;; past any incomplete opening delimiters + (setq start (line-beginning-position)) + (setq end (max (nxml-scan-after-change start end) + end)))) + (when nxml-syntax-highlight-flag + (when (>= start end) + ;; Must clear at least one char so as to trigger redisplay. + (cond ((< start (point-max)) + (setq end (1+ start))) + (t + (setq end (point-max)) + (goto-char end) + (setq start (line-beginning-position))))) + (nxml-clear-fontified start end))) + +;;; Encodings + +(defun nxml-insert-xml-declaration () + "Insert an XML declaration at the beginning of buffer. +The XML declaration will declare an encoding depending on the buffer's +`buffer-file-coding-system'." + (interactive "*") + (let ((coding-system + (if (and buffer-file-coding-system + (coding-system-p buffer-file-coding-system) + (coding-system-get buffer-file-coding-system + 'mime-charset)) + buffer-file-coding-system + (nxml-choose-utf-coding-system)))) + (goto-char (point-min)) + (insert (format "<?xml version=\"1.0\" encoding=\"%s\"?>\n" + (nxml-coding-system-name coding-system))))) + +(defun nxml-prepare-to-save () + (unless (and (not enable-multibyte-characters) + (local-variable-p 'buffer-file-coding-system) + buffer-file-coding-system + (or (eq (coding-system-type buffer-file-coding-system) 5) + (eq buffer-file-coding-system 'no-conversion))) + (save-excursion + (setq buffer-file-coding-system (nxml-select-coding-system)))) + ;; nil from a function in `write-contents-hooks' means + ;; to continue and write the file as normal + nil) + +(defun nxml-select-coding-system () + (let* ((suitable-coding-systems + (find-coding-systems-region (point-min) (point-max))) + (enc-pos (progn + (goto-char (point-min)) + (xmltok-get-declared-encoding-position))) + (enc-name + (and (consp enc-pos) + (buffer-substring-no-properties (car enc-pos) + (cdr enc-pos)))) + (coding-system + (cond (enc-name + (if (string= (downcase enc-name) "utf-16") + (nxml-choose-utf-16-coding-system) + (nxml-mime-charset-coding-system enc-name))) + (enc-pos (nxml-choose-utf-coding-system))))) + ;; Make sure we have a coding-system + (unless coding-system + (setq coding-system + (and (not buffer-read-only) + (nxml-choose-suitable-coding-system + suitable-coding-systems))) + (let ((message + (if enc-name + (format "Unknown encoding %s" enc-name) + "XML declaration is not well-formed"))) + (cond ((not coding-system) + (error "%s" message)) + ((y-or-n-p + (concat message + ". " + (format (if enc-name + "Save with %s" + "Modify and save with encoding %s") + (nxml-coding-system-name coding-system)) + " ")) + (nxml-fix-encoding-declaration enc-pos coding-system)) + (t (signal 'quit nil))))) + ;; Make sure it can encode all the characters in the buffer + (unless (or (memq (coding-system-base coding-system) + suitable-coding-systems) + (equal suitable-coding-systems '(undecided))) + (let ((message + (nxml-unsuitable-coding-system-message coding-system + enc-name))) + (setq coding-system + (and (not buffer-read-only) + (nxml-choose-suitable-coding-system + suitable-coding-systems))) + (cond ((not coding-system) (error "%s" message)) + ((y-or-n-p (concat message + (format ". Save with %s " + (nxml-coding-system-name + coding-system)))) + (nxml-fix-encoding-declaration enc-pos coding-system)) + (t (signal 'quit nil))))) + ;; Merge the newline type of our existing encoding + (let ((current-eol-type + (coding-system-eol-type buffer-file-coding-system))) + (when (and current-eol-type (integerp current-eol-type)) + (setq coding-system + (coding-system-change-eol-conversion coding-system + current-eol-type)))) + coding-system)) + +(defun nxml-unsuitable-coding-system-message (coding-system &optional enc-name) + (if (nxml-coding-system-unicode-p coding-system) + "Cannot translate some characters to Unicode" + (format "Cannot encode some characters with %s" + (or enc-name + (nxml-coding-system-name coding-system))))) + +(defconst nxml-utf-16-coding-systems (and (coding-system-p 'utf-16-be) + (coding-system-p 'utf-16-le) + '(utf-16-be utf-16-le))) + +(defconst nxml-utf-coding-systems (cons 'utf-8 nxml-utf-16-coding-systems)) + +(defun nxml-coding-system-unicode-p (coding-system) + (nxml-coding-system-member (coding-system-base coding-system) + nxml-utf-coding-systems)) + +(defun nxml-coding-system-name (coding-system) + (setq coding-system (coding-system-base coding-system)) + (symbol-name + (if (nxml-coding-system-member coding-system nxml-utf-16-coding-systems) + 'utf-16 + (or (coding-system-get coding-system 'mime-charset) + coding-system)))) + +(defun nxml-fix-encoding-declaration (enc-pos coding-system) + (let ((charset (nxml-coding-system-name coding-system))) + (cond ((consp enc-pos) + (delete-region (car enc-pos) (cdr enc-pos)) + (goto-char (car enc-pos)) + (insert charset)) + ((integerp enc-pos) + (goto-char enc-pos) + (insert " encoding=\"" charset ?\")) + (t + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"" + charset + "\"?>\n") + (when (and (not enc-pos) + (let ((case-fold-search t)) + (looking-at xmltok-bad-xml-decl-regexp))) + (delete-region (point) (match-end 0))))))) + +(defun nxml-choose-suitable-coding-system (suitable-coding-systems) + (let (ret coding-system) + (if (and buffer-file-coding-system + (memq (coding-system-base buffer-file-coding-system) + suitable-coding-systems)) + buffer-file-coding-system + (while (and suitable-coding-systems (not ret)) + (setq coding-system (car suitable-coding-systems)) + (if (coding-system-get coding-system 'mime-charset) + (setq ret coding-system) + (setq suitable-coding-systems (cdr suitable-coding-systems)))) + ret))) + +(defun nxml-choose-utf-coding-system () + (let ((cur (and (local-variable-p 'buffer-file-coding-system) + buffer-file-coding-system + (coding-system-base buffer-file-coding-system)))) + (cond ((car (nxml-coding-system-member cur nxml-utf-coding-systems))) + ((and nxml-prefer-utf-16-to-utf-8-flag + (coding-system-p 'utf-16-le) + (coding-system-p 'utf-16-be)) + (if nxml-prefer-utf-16-little-to-big-endian-flag + 'utf-16-le + 'utf-16-be)) + (t 'utf-8)))) + +(defun nxml-choose-utf-16-coding-system () + (let ((cur (and (local-variable-p 'buffer-file-coding-system) + buffer-file-coding-system + (coding-system-base buffer-file-coding-system)))) + (cond ((car (nxml-coding-system-member cur nxml-utf-16-coding-systems))) + (nxml-prefer-utf-16-little-to-big-endian-flag + (and (coding-system-p 'utf-16-le) 'utf-16-le)) + (t (and (coding-system-p 'utf-16-be) 'utf-16-be))))) + +(defun nxml-coding-system-member (coding-system coding-systems) + (let (ret) + (while (and coding-systems (not ret)) + (if (coding-system-equal coding-system + (car coding-systems)) + (setq ret coding-systems) + (setq coding-systems (cdr coding-systems)))) + ret)) + +;;; Fontification + +(defun nxml-fontify (start) + (condition-case err + (save-excursion + (save-restriction + (widen) + (save-match-data + (nxml-with-invisible-motion + (nxml-with-unmodifying-text-property-changes + (if (or nxml-degraded + ;; just in case we get called in the wrong buffer + (not nxml-prolog-end)) + (nxml-set-fontified start (point-max)) + (nxml-fontify1 start))))))) + (error + (nxml-degrade 'nxml-fontify err)))) + +(defun nxml-fontify1 (start) + (cond ((< start nxml-prolog-end) + (nxml-fontify-prolog) + (nxml-set-fontified (point-min) + nxml-prolog-end)) + (t + (goto-char start) + (when (not (eq nxml-last-fontify-end start)) + (when (not (equal (char-after) ?\<)) + (search-backward "<" nxml-prolog-end t)) + (nxml-ensure-scan-up-to-date) + (nxml-move-outside-backwards)) + (let ((start (point))) + (nxml-do-fontify (min (point-max) + (+ start nxml-fontify-chunk-size))) + (setq nxml-last-fontify-end (point)) + (nxml-set-fontified start nxml-last-fontify-end))))) + +(defun nxml-fontify-buffer () + (interactive) + (save-excursion + (save-restriction + (widen) + (nxml-with-invisible-motion + (goto-char (point-min)) + (nxml-with-unmodifying-text-property-changes + (nxml-fontify-prolog) + (goto-char nxml-prolog-end) + (nxml-do-fontify)))))) + +(defun nxml-fontify-prolog () + "Fontify the prolog. +The buffer is assumed to be prepared for fontification. +This does not set the fontified property, but it does clear +faces appropriately." + (let ((regions nxml-prolog-regions)) + (nxml-clear-face (point-min) nxml-prolog-end) + (while regions + (let ((region (car regions))) + (nxml-apply-fontify-rule (aref region 0) + (aref region 1) + (aref region 2))) + (setq regions (cdr regions))))) + +(defun nxml-do-fontify (&optional bound) + "Fontify at least as far as bound. +Leave point after last fontified position." + (unless bound (setq bound (point-max))) + (let (xmltok-dependent-regions + xmltok-errors) + (while (and (< (point) bound) + (nxml-tokenize-forward)) + (nxml-clear-face xmltok-start (point)) + (nxml-apply-fontify-rule)))) + +;; Vectors identify a substring of the token to be highlighted in some face. + +;; Token types returned by xmltok-forward. + +(put 'start-tag + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + [-1 nil nxml-tag-delimiter-face] + (element-qname . 1) + attributes)) + +(put 'partial-start-tag + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + (element-qname . 1) + attributes)) + +(put 'end-tag + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + [1 2 nxml-tag-slash-face] + [-1 nil nxml-tag-delimiter-face] + (element-qname . 2))) + +(put 'partial-end-tag + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + [1 2 nxml-tag-slash-face] + (element-qname . 2))) + +(put 'empty-element + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + [-2 -1 nxml-tag-slash-face] + [-1 nil nxml-tag-delimiter-face] + (element-qname . 1) + attributes)) + +(put 'partial-empty-element + 'nxml-fontify-rule + '([nil 1 nxml-tag-delimiter-face] + [-1 nil nxml-tag-slash-face] + (element-qname . 1) + attributes)) + +(put 'char-ref + 'nxml-fontify-rule + '([nil 2 nxml-char-ref-delimiter-face] + [2 -1 nxml-char-ref-number-face] + [-1 nil nxml-char-ref-delimiter-face] + char-ref)) + +(put 'entity-ref + 'nxml-fontify-rule + '([nil 1 nxml-entity-ref-delimiter-face] + [1 -1 nxml-entity-ref-name-face] + [-1 nil nxml-entity-ref-delimiter-face])) + +(put 'comment + 'nxml-fontify-rule + '([nil 4 nxml-comment-delimiter-face] + [4 -3 nxml-comment-content-face] + [-3 nil nxml-comment-delimiter-face])) + +(put 'processing-instruction + 'nxml-fontify-rule + '([nil 2 nxml-processing-instruction-delimiter-face] + [-2 nil nxml-processing-instruction-delimiter-face] + processing-instruction-content)) + +(put 'cdata-section + 'nxml-fontify-rule + '([nil 3 nxml-cdata-section-delimiter-face] ; <![ + [3 8 nxml-cdata-section-CDATA-face] ; CDATA + [8 9 nxml-cdata-section-delimiter-face] ; [ + [9 -3 nxml-cdata-section-content-face] ; ]]> + [-3 nil nxml-cdata-section-delimiter-face])) + +(put 'data + 'nxml-fontify-rule + '([nil nil nxml-text-face])) + +;; Prolog region types in list returned by xmltok-forward-prolog. + +(put 'xml-declaration + 'nxml-fontify-rule + '([nil 2 nxml-processing-instruction-delimiter-face] + [2 5 nxml-processing-instruction-target-face] + [-2 nil nxml-processing-instruction-delimiter-face])) + +(put 'xml-declaration-attribute-name + 'nxml-fontify-rule + '([nil nil nxml-attribute-local-name-face])) + +(put 'xml-declaration-attribute-value + 'nxml-fontify-rule + '([nil 1 nxml-attribute-value-delimiter-face] + [1 -1 nxml-attribute-value-face] + [-1 nil nxml-attribute-value-delimiter-face])) + +(put 'processing-instruction-left + 'nxml-fontify-rule + '([nil 2 nxml-processing-instruction-delimiter-face] + [2 nil nxml-processing-instruction-target-face])) + +(put 'processing-instruction-right + 'nxml-fontify-rule + '([nil -2 nxml-processing-instruction-content-face] + [-2 nil nxml-processing-instruction-delimiter-face])) + +(put 'literal + 'nxml-fontify-rule + '([nil 1 nxml-prolog-literal-delimiter-face] + [1 -1 nxml-prolog-literal-content-face] + [-1 nil nxml-prolog-literal-delimiter-face])) + +(put 'keyword + 'nxml-fontify-rule + '([nil nil nxml-prolog-keyword-face])) + +(put 'markup-declaration-open + 'nxml-fontify-rule + '([0 2 nxml-markup-declaration-delimiter-face] + [2 nil nxml-prolog-keyword-face])) + +(put 'markup-declaration-close + 'nxml-fontify-rule + '([nil nil nxml-markup-declaration-delimiter-face])) + +(put 'internal-subset-open + 'nxml-fontify-rule + '([nil nil nxml-markup-declaration-delimiter-face])) + +(put 'internal-subset-close + 'nxml-fontify-rule + '([nil 1 nxml-markup-declaration-delimiter-face] + [-1 nil nxml-markup-declaration-delimiter-face])) + +(put 'hash-name + 'nxml-fontify-rule + '([nil 1 nxml-hash-face] + [1 nil nxml-prolog-keyword-face])) + +(defun nxml-apply-fontify-rule (&optional type start end) + (let ((rule (get (or type xmltok-type) 'nxml-fontify-rule))) + (unless start (setq start xmltok-start)) + (unless end (setq end (point))) + (while rule + (let* ((action (car rule))) + (setq rule (cdr rule)) + (cond ((vectorp action) + (nxml-set-face (let ((offset (aref action 0))) + (cond ((not offset) start) + ((< offset 0) (+ end offset)) + (t (+ start offset)))) + (let ((offset (aref action 1))) + (cond ((not offset) end) + ((< offset 0) (+ end offset)) + (t (+ start offset)))) + (aref action 2))) + ((and (consp action) + (eq (car action) 'element-qname)) + (when xmltok-name-end ; maybe nil in partial-end-tag case + (nxml-fontify-qname (+ start (cdr action)) + xmltok-name-colon + xmltok-name-end + 'nxml-element-prefix-face + 'nxml-element-colon-face + 'nxml-element-local-name-face))) + ((eq action 'attributes) + (nxml-fontify-attributes)) + ((eq action 'processing-instruction-content) + (nxml-set-face (+ start 2) + xmltok-name-end + 'nxml-processing-instruction-target-face) + (nxml-set-face (save-excursion + (goto-char xmltok-name-end) + (skip-chars-forward " \t\r\n") + (point)) + (- end 2) + 'nxml-processing-instruction-content-face)) + ((eq action 'char-ref) + (nxml-char-ref-display-extra start + end + (xmltok-char-number start end))) + (t (error "Invalid nxml-fontify-rule action %s" action))))))) + +(defun nxml-fontify-attributes () + (while xmltok-namespace-attributes + (nxml-fontify-attribute (car xmltok-namespace-attributes) + 'namespace) + (setq xmltok-namespace-attributes + (cdr xmltok-namespace-attributes))) + (while xmltok-attributes + (nxml-fontify-attribute (car xmltok-attributes)) + (setq xmltok-attributes + (cdr xmltok-attributes)))) + +(defun nxml-fontify-attribute (att &optional namespace-declaration) + (if namespace-declaration + (nxml-fontify-qname (xmltok-attribute-name-start att) + (xmltok-attribute-name-colon att) + (xmltok-attribute-name-end att) + 'nxml-namespace-attribute-xmlns-face + 'nxml-namespace-attribute-colon-face + 'nxml-namespace-attribute-prefix-face + 'nxml-namespace-attribute-xmlns-face) + (nxml-fontify-qname (xmltok-attribute-name-start att) + (xmltok-attribute-name-colon att) + (xmltok-attribute-name-end att) + 'nxml-attribute-prefix-face + 'nxml-attribute-colon-face + 'nxml-attribute-local-name-face)) + (let ((start (xmltok-attribute-value-start att)) + (end (xmltok-attribute-value-end att)) + (refs (xmltok-attribute-refs att)) + (delimiter-face (if namespace-declaration + 'nxml-namespace-attribute-value-delimiter-face + 'nxml-attribute-value-delimiter-face)) + (value-face (if namespace-declaration + 'nxml-namespace-attribute-value-face + 'nxml-attribute-value-face))) + (when start + (nxml-set-face (1- start) start delimiter-face) + (nxml-set-face end (1+ end) delimiter-face) + (while refs + (let* ((ref (car refs)) + (ref-type (aref ref 0)) + (ref-start (aref ref 1)) + (ref-end (aref ref 2))) + (nxml-set-face start ref-start value-face) + (nxml-apply-fontify-rule ref-type ref-start ref-end) + (setq start ref-end)) + (setq refs (cdr refs))) + (nxml-set-face start end value-face)))) + +(defun nxml-fontify-qname (start + colon + end + prefix-face + colon-face + local-name-face + &optional + unprefixed-face) + (cond (colon (nxml-set-face start colon prefix-face) + (nxml-set-face colon (1+ colon) colon-face) + (nxml-set-face (1+ colon) end local-name-face)) + (t (nxml-set-face start end (or unprefixed-face + local-name-face))))) + +;;; Editing + +(defun nxml-electric-slash (arg) + "Insert a slash. + +With a prefix ARG, do nothing other than insert the slash. + +Otherwise, if `nxml-slash-auto-complete-flag' is non-nil, insert the +rest of the end-tag or empty-element if the slash is potentially part +of an end-tag or the close of an empty-element. + +If the slash is part of an end-tag that is the first non-whitespace +on the line, reindent the line." + (interactive "*P") + (nxml-ensure-scan-up-to-date) + (let* ((slash-pos (point)) + (end-tag-p (and (eq (char-before slash-pos) ?<) + (not (nxml-get-inside slash-pos)))) + (at-indentation (save-excursion + (back-to-indentation) + (eq (point) (1- slash-pos))))) + (self-insert-command (prefix-numeric-value arg)) + (unless arg + (if nxml-slash-auto-complete-flag + (if end-tag-p + (condition-case err + (let ((start-tag-end + (nxml-scan-element-backward (1- slash-pos) t))) + (when start-tag-end + (insert (xmltok-start-tag-qname) ">") + ;; copy the indentation of the start-tag + (when (and at-indentation + (save-excursion + (goto-char xmltok-start) + (back-to-indentation) + (eq (point) xmltok-start))) + (save-excursion + (indent-line-to (save-excursion + (goto-char xmltok-start) + (current-column))))))) + (nxml-scan-error nil)) + (when (and (eq (nxml-token-before) (point)) + (eq xmltok-type 'partial-empty-element)) + (insert ">"))) + (when (and end-tag-p at-indentation) + (nxml-indent-line)))))) + +(defun nxml-balanced-close-start-tag-block () + "Close the start-tag before point with `>' and insert a balancing end-tag. +Point is left between the start-tag and the end-tag. +If there is nothing but whitespace before the `<' that opens the +start-tag, then put point on a blank line, and put the end-tag on +another line aligned with the start-tag." + (interactive "*") + (nxml-balanced-close-start-tag 'block)) + +(defun nxml-balanced-close-start-tag-inline () + "Close the start-tag before point with `>' and insert a balancing end-tag. +Point is left between the start-tag and the end-tag. +No extra whitespace is inserted." + (interactive "*") + (nxml-balanced-close-start-tag 'inline)) + +(defun nxml-balanced-close-start-tag (block-or-inline) + (let ((token-end (nxml-token-before)) + (pos (1+ (point)))) + (unless (or (eq xmltok-type 'partial-start-tag) + (and (memq xmltok-type '(start-tag + empty-element + partial-empty-element)) + (>= token-end pos))) + (error "Not in a start-tag")) + (insert "></" + (buffer-substring-no-properties (+ xmltok-start 1) + (min xmltok-name-end (point))) + ">") + (if (eq block-or-inline 'inline) + (goto-char pos) + (goto-char xmltok-start) + (back-to-indentation) + (if (= (point) xmltok-start) + (let ((indent (current-column))) + (goto-char pos) + (insert "\n") + (indent-line-to indent) + (goto-char pos) + (insert "\n") + (indent-line-to (+ nxml-child-indent indent))) + (goto-char pos))))) + +(defun nxml-finish-element () + "Finish the current element by inserting an end-tag." + (interactive "*") + (nxml-finish-element-1 nil)) + +(defvar nxml-last-split-position nil + "Position where `nxml-split-element' split the current element.") + +(defun nxml-split-element () + "Split the current element by inserting an end-tag and a start-tag. +Point is left after the newly inserted start-tag. When repeated, +split immediately before the previously inserted start-tag and leave +point unchanged." + (interactive "*") + (setq nxml-last-split-position + (if (and (eq last-command this-command) + nxml-last-split-position) + (save-excursion + (goto-char nxml-last-split-position) + (nxml-finish-element-1 t)) + (nxml-finish-element-1 t)))) + +(defun nxml-finish-element-1 (startp) + "Insert an end-tag for the current element and optionally a start-tag. +The start-tag is inserted if STARTP is non-nil. Return the position +of the inserted start-tag or nil if none was inserted." + (interactive "*") + (let* ((token-end (nxml-token-before)) + (start-tag-end + (save-excursion + (when (and (< (point) token-end) + (memq xmltok-type + '(cdata-section + processing-instruction + comment + start-tag + end-tag + empty-element))) + (error "Point is inside a %s" + (nxml-token-type-friendly-name xmltok-type))) + (nxml-scan-element-backward token-end t))) + (starts-line + (save-excursion + (unless (eq xmltok-type 'start-tag) + (error "No matching start-tag")) + (goto-char xmltok-start) + (back-to-indentation) + (eq (point) xmltok-start))) + (ends-line + (save-excursion + (goto-char start-tag-end) + (looking-at "[ \t\r\n]*$"))) + (start-tag-indent (save-excursion + (goto-char xmltok-start) + (current-column))) + (qname (xmltok-start-tag-qname)) + inserted-start-tag-pos) + (when (and starts-line ends-line) + ;; start-tag is on a line by itself + ;; => put the end-tag on a line by itself + (unless (<= (point) + (save-excursion + (back-to-indentation) + (point))) + (insert "\n")) + (indent-line-to start-tag-indent)) + (insert "</" qname ">") + (when startp + (when starts-line + (insert "\n") + (indent-line-to start-tag-indent)) + (setq inserted-start-tag-pos (point)) + (insert "<" qname ">") + (when (and starts-line ends-line) + (insert "\n") + (indent-line-to (save-excursion + (goto-char xmltok-start) + (forward-line 1) + (back-to-indentation) + (if (= (current-column) + (+ start-tag-indent nxml-child-indent)) + (+ start-tag-indent nxml-child-indent) + start-tag-indent))))) + inserted-start-tag-pos)) + +;;; Indentation + +(defun nxml-indent-line () + "Indent current line as XML." + (let ((indent (nxml-compute-indent)) + (from-end (- (point-max) (point)))) + (when indent + (beginning-of-line) + (let ((bol (point))) + (skip-chars-forward " \t") + (delete-region bol (point))) + (indent-to indent) + (when (> (- (point-max) from-end) (point)) + (goto-char (- (point-max) from-end)))))) + +(defun nxml-compute-indent () + "Return the indent for the line containing point." + (or (nxml-compute-indent-from-matching-start-tag) + (nxml-compute-indent-from-previous-line))) + +(defun nxml-compute-indent-from-matching-start-tag () + "Compute the indent for a line with an end-tag using the matching start-tag. +When the line containing point ends with an end-tag and does not start +in the middle of a token, return the indent of the line containing the +matching start-tag, if there is one and it occurs at the beginning of +its line. Otherwise return nil." + (save-excursion + (back-to-indentation) + (let ((bol (point))) + (let ((inhibit-field-text-motion t)) + (end-of-line)) + (skip-chars-backward " \t") + (and (= (nxml-token-before) (point)) + (memq xmltok-type '(end-tag partial-end-tag)) + ;; start of line must not be inside a token + (or (= xmltok-start bol) + (save-excursion + (goto-char bol) + (nxml-token-after) + (= xmltok-start bol)) + (eq xmltok-type 'data)) + (condition-case err + (nxml-scan-element-backward + (point) + nil + (- (point) + nxml-end-tag-indent-scan-distance)) + (nxml-scan-error nil)) + (< xmltok-start bol) + (progn + (goto-char xmltok-start) + (skip-chars-backward " \t") + (bolp)) + (current-indentation))))) + +(defun nxml-compute-indent-from-previous-line () + "Compute the indent for a line using the indentation of a previous line." + (save-excursion + (end-of-line) + (let ((eol (point)) + bol prev-bol ref + before-context after-context) + (back-to-indentation) + (setq bol (point)) + (catch 'indent + ;; Move backwards until the start of a non-blank line that is + ;; not inside a token. + (while (progn + (when (= (forward-line -1) -1) + (throw 'indent 0)) + (back-to-indentation) + (if (looking-at "[ \t]*$") + t + (or prev-bol + (setq prev-bol (point))) + (nxml-token-after) + (not (or (= xmltok-start (point)) + (eq xmltok-type 'data)))))) + (setq ref (point)) + ;; Now scan over tokens until the end of the line to be indented. + ;; Determine the context before and after the beginning of the + ;; line. + (while (< (point) eol) + (nxml-tokenize-forward) + (cond ((<= bol xmltok-start) + (setq after-context + (nxml-merge-indent-context-type after-context))) + ((and (<= (point) bol) + (not (and (eq xmltok-type 'partial-start-tag) + (= (point) bol)))) + (setq before-context + (nxml-merge-indent-context-type before-context))) + ((eq xmltok-type 'data) + (setq before-context + (nxml-merge-indent-context-type before-context)) + (setq after-context + (nxml-merge-indent-context-type after-context))) + ;; If in the middle of a token that looks inline, + ;; then indent relative to the previous non-blank line + ((eq (nxml-merge-indent-context-type before-context) + 'mixed) + (goto-char prev-bol) + (throw 'indent (current-column))) + (t + (throw 'indent + (nxml-compute-indent-in-token bol)))) + (skip-chars-forward " \t\r\n")) + (goto-char ref) + (+ (current-column) + (* nxml-child-indent + (+ (if (eq before-context 'start-tag) 1 0) + (if (eq after-context 'end-tag) -1 0)))))))) + +(defun nxml-merge-indent-context-type (context) + "Merge the indent context type CONTEXT with the token in `xmltok-type'. +Return the merged indent context type. An indent context type is +either nil or one of the symbols start-tag, end-tag, markup, comment, +mixed." + (cond ((memq xmltok-type '(start-tag partial-start-tag)) + (if (memq context '(nil start-tag comment)) + 'start-tag + 'mixed)) + ((memq xmltok-type '(end-tag partial-end-tag)) + (if (memq context '(nil end-tag comment)) + 'end-tag + 'mixed)) + ((eq xmltok-type 'comment) + (cond ((memq context '(start-tag end-tag comment)) + context) + (context 'mixed) + (t 'comment))) + (context 'mixed) + (t 'markup))) + +(defun nxml-compute-indent-in-token (pos) + "Return the indent for a line that starts inside a token. +POS is the position of the first non-whitespace character of the line. +This expects the xmltok-* variables to be set up as by `xmltok-forward'." + (cond ((memq xmltok-type '(start-tag + partial-start-tag + empty-element + partial-empty-element)) + (nxml-compute-indent-in-start-tag pos)) + ((eq xmltok-type 'comment) + (nxml-compute-indent-in-delimited-token pos "<!--" "-->")) + ((eq xmltok-type 'cdata-section) + (nxml-compute-indent-in-delimited-token pos "<![CDATA[" "]]>")) + ((eq xmltok-type 'processing-instruction) + (nxml-compute-indent-in-delimited-token pos "<?" "?>")) + (t + (goto-char pos) + (if (and (= (forward-line -1) 0) + (< xmltok-start (point))) + (back-to-indentation) + (goto-char xmltok-start)) + (current-column)))) + +(defun nxml-compute-indent-in-start-tag (pos) + "Return the indent for a line that starts inside a start-tag. +Also for a line that starts inside an empty element. +POS is the position of the first non-whitespace character of the line. +This expects the xmltok-* variables to be set up as by `xmltok-forward'." + (let ((value-boundary (nxml-attribute-value-boundary pos)) + (off 0)) + (if value-boundary + ;; inside an attribute value + (let ((value-start (car value-boundary)) + (value-end (cdr value-boundary))) + (goto-char pos) + (forward-line -1) + (if (< (point) value-start) + (goto-char value-start) + (back-to-indentation))) + ;; outside an attribute value + (goto-char pos) + (while (and (= (forward-line -1) 0) + (nxml-attribute-value-boundary (point)))) + (cond ((<= (point) xmltok-start) + (goto-char xmltok-start) + (setq off nxml-attribute-indent) + (let ((atts (xmltok-merge-attributes))) + (when atts + (let* ((att (car atts)) + (start (xmltok-attribute-name-start att))) + (when (< start pos) + (goto-char start) + (setq off 0)))))) + (t + (back-to-indentation)))) + (+ (current-column) off))) + +(defun nxml-attribute-value-boundary (pos) + "Return a pair (START . END) if POS is inside an attribute value. +Otherwise return nil. START and END are the positions of the start +and end of the attribute value containing POS. This expects the +xmltok-* variables to be set up as by `xmltok-forward'." + (let ((atts (xmltok-merge-attributes)) + att value-start value-end value-boundary) + (while atts + (setq att (car atts)) + (setq value-start (xmltok-attribute-value-start att)) + (setq value-end (xmltok-attribute-value-end att)) + (cond ((and value-start (< pos value-start)) + (setq atts nil)) + ((and value-start value-end (<= pos value-end)) + (setq value-boundary (cons value-start value-end)) + (setq atts nil)) + (t (setq atts (cdr atts))))) + value-boundary)) + +(defun nxml-compute-indent-in-delimited-token (pos open-delim close-delim) + "Return the indent for a line that starts inside a token with delimiters. +OPEN-DELIM and CLOSE-DELIM are strings giving the opening and closing +delimiters. POS is the position of the first non-whitespace character +of the line. This expects the xmltok-* variables to be set up as by +`xmltok-forward'." + (cond ((let ((end (+ pos (length close-delim)))) + (and (<= end (point-max)) + (string= (buffer-substring-no-properties pos end) + close-delim))) + (goto-char xmltok-start)) + ((progn + (goto-char pos) + (forward-line -1) + (<= (point) xmltok-start)) + (goto-char (+ xmltok-start (length open-delim))) + (when (and (string= open-delim "<!--") + (looking-at " ")) + (goto-char (1+ (point))))) + (t (back-to-indentation))) + (current-column)) + +;;; Completion + +(defun nxml-complete () + "Perform completion on the symbol preceding point. + +Inserts as many characters as can be completed. However, if not even +one character can be completed, then a buffer with the possibilities +is popped up and the symbol is read from the minibuffer with +completion. If the symbol is complete, then any characters that must +follow the symbol are also inserted. + +The name space used for completion and what is treated as a symbol +depends on the context. The contexts in which completion is performed +depend on `nxml-completion-hook'." + (interactive) + (unless (run-hook-with-args-until-success 'nxml-completion-hook) + ;; Eventually we will complete on entity names here. + (ding) + (message "Cannot complete in this context"))) + +;;; Movement + +(defun nxml-forward-balanced-item (&optional arg) + "Move forward across one balanced item. +With ARG, do it that many times. Negative arg -N means +move backward across N balanced expressions. +This is the equivalent of `forward-sexp' for XML. + +An element contains as items strings with no markup, tags, processing +instructions, comments, CDATA sections, entity references and +characters references. However, if the variable +`nxml-sexp-element-flag' is non-nil, then an element is treated as a +single markup item. A start-tag contains an element name followed by +one or more attributes. An end-tag contains just an element name. An +attribute value literals contains strings with no markup, entity +references and character references. A processing instruction +consists of a target and a content string. A comment or a CDATA +section contains a single string. An entity reference contains a +single name. A character reference contains a character number." + (interactive "p") + (or arg (setq arg 1)) + (cond ((> arg 0) + (while (progn + (nxml-forward-single-balanced-item) + (> (setq arg (1- arg)) 0)))) + ((< arg 0) + (while (progn + (nxml-backward-single-balanced-item) + (< (setq arg (1+ arg)) 0)))))) + +(defun nxml-forward-single-balanced-item () + (condition-case err + (goto-char (let ((end (nxml-token-after))) + (save-excursion + (while (eq xmltok-type 'space) + (goto-char end) + (setq end (nxml-token-after))) + (cond ((/= (point) xmltok-start) + (nxml-scan-forward-within end)) + ((and nxml-sexp-element-flag + (eq xmltok-type 'start-tag)) + ;; can't ever return nil here + (nxml-scan-element-forward xmltok-start)) + ((and nxml-sexp-element-flag + (memq xmltok-type + '(end-tag partial-end-tag))) + (error "Already at end of element")) + (t end))))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err))))) + +(defun nxml-backward-single-balanced-item () + (condition-case err + (goto-char (let ((end (nxml-token-before))) + (save-excursion + (while (eq xmltok-type 'space) + (goto-char xmltok-start) + (setq end (nxml-token-before))) + (cond ((/= (point) end) + (nxml-scan-backward-within end)) + ((and nxml-sexp-element-flag + (eq xmltok-type 'end-tag)) + ;; can't ever return nil here + (nxml-scan-element-backward end) + xmltok-start) + ((and nxml-sexp-element-flag + (eq xmltok-type 'start-tag)) + (error "Already at start of element")) + (t xmltok-start))))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err))))) + +(defun nxml-scan-forward-within (end) + (setq end (- end (nxml-end-delimiter-length xmltok-type))) + (when (<= end (point)) + (error "Already at end of %s" + (nxml-token-type-friendly-name xmltok-type))) + (cond ((memq xmltok-type '(start-tag + empty-element + partial-start-tag + partial-empty-element)) + (if (< (point) xmltok-name-end) + xmltok-name-end + (let ((att (nxml-find-following-attribute))) + (cond ((not att) end) + ((and (xmltok-attribute-value-start att) + (<= (xmltok-attribute-value-start att) + (point))) + (nxml-scan-forward-in-attribute-value att)) + ((xmltok-attribute-value-end att) + (1+ (xmltok-attribute-value-end att))) + ((save-excursion + (goto-char (xmltok-attribute-name-end att)) + (looking-at "[ \t\r\n]*=")) + (match-end 0)) + (t (xmltok-attribute-name-end att)))))) + ((and (eq xmltok-type 'processing-instruction) + (< (point) xmltok-name-end)) + xmltok-name-end) + (t end))) + +(defun nxml-scan-backward-within (end) + (setq xmltok-start + (+ xmltok-start + (nxml-start-delimiter-length xmltok-type))) + (when (<= (point) xmltok-start) + (error "Already at start of %s" + (nxml-token-type-friendly-name xmltok-type))) + (cond ((memq xmltok-type '(start-tag + empty-element + partial-start-tag + partial-empty-element)) + (let ((att (nxml-find-preceding-attribute))) + (cond ((not att) xmltok-start) + ((and (xmltok-attribute-value-start att) + (<= (xmltok-attribute-value-start att) + (point)) + (<= (point) + (xmltok-attribute-value-end att))) + (nxml-scan-backward-in-attribute-value att)) + (t (xmltok-attribute-name-start att))))) + ((and (eq xmltok-type 'processing-instruction) + (let ((content-start (save-excursion + (goto-char xmltok-name-end) + (skip-chars-forward " \r\t\n") + (point)))) + (and (< content-start (point)) + content-start)))) + (t xmltok-start))) + +(defun nxml-scan-forward-in-attribute-value (att) + (when (= (point) (xmltok-attribute-value-end att)) + (error "Already at end of attribute value")) + (let ((refs (xmltok-attribute-refs att)) + ref) + (while refs + (setq ref (car refs)) + (if (< (point) (aref ref 2)) + (setq refs nil) + (setq ref nil) + (setq refs (cdr refs)))) + (cond ((not ref) + (xmltok-attribute-value-end att)) + ((< (point) (aref ref 1)) + (aref ref 1)) + ((= (point) (aref ref 1)) + (aref ref 2)) + (t + (let ((end (- (aref ref 2) + (nxml-end-delimiter-length (aref ref 0))))) + (if (< (point) end) + end + (error "Already at end of %s" + (nxml-token-type-friendly-name (aref ref 0))))))))) + +(defun nxml-scan-backward-in-attribute-value (att) + (when (= (point) (xmltok-attribute-value-start att)) + (error "Already at start of attribute value")) + (let ((refs (reverse (xmltok-attribute-refs att))) + ref) + (while refs + (setq ref (car refs)) + (if (< (aref ref 1) (point)) + (setq refs nil) + (setq ref nil) + (setq refs (cdr refs)))) + (cond ((not ref) + (xmltok-attribute-value-start att)) + ((< (aref ref 2) (point)) + (aref ref 2)) + ((= (point) (aref ref 2)) + (aref ref 1)) + (t + (let ((start (+ (aref ref 1) + (nxml-start-delimiter-length (aref ref 0))))) + (if (< start (point)) + start + (error "Already at start of %s" + (nxml-token-type-friendly-name (aref ref 0))))))))) + +(defun nxml-find-following-attribute () + (let ((ret nil) + (atts (or xmltok-attributes xmltok-namespace-attributes)) + (more-atts (and xmltok-attributes xmltok-namespace-attributes))) + (while atts + (let* ((att (car atts)) + (name-start (xmltok-attribute-name-start att))) + (cond ((and (<= name-start (point)) + (xmltok-attribute-value-end att) + ;; <= because end is before quote + (<= (point) (xmltok-attribute-value-end att))) + (setq atts nil) + (setq ret att)) + ((and (< (point) name-start) + (or (not ret) + (< name-start + (xmltok-attribute-name-start ret)))) + (setq ret att)))) + (setq atts (cdr atts)) + (unless atts + (setq atts more-atts) + (setq more-atts nil))) + ret)) + +(defun nxml-find-preceding-attribute () + (let ((ret nil) + (atts (or xmltok-attributes xmltok-namespace-attributes)) + (more-atts (and xmltok-attributes xmltok-namespace-attributes))) + (while atts + (let* ((att (car atts)) + (name-start (xmltok-attribute-name-start att))) + (cond ((and (< name-start (point)) + (xmltok-attribute-value-end att) + ;; <= because end is before quote + (<= (point) (xmltok-attribute-value-end att))) + (setq atts nil) + (setq ret att)) + ((and (< name-start (point)) + (or (not ret) + (< (xmltok-attribute-name-start ret) + name-start))) + (setq ret att)))) + (setq atts (cdr atts)) + (unless atts + (setq atts more-atts) + (setq more-atts nil))) + ret)) + +(defun nxml-up-element (&optional arg) + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-backward-up-element (- arg)) + (condition-case err + (while (and (> arg 0) + (< (point) (point-max))) + (let ((token-end (nxml-token-after))) + (goto-char (cond ((or (memq xmltok-type '(end-tag + partial-end-tag)) + (and (memq xmltok-type + '(empty-element + partial-empty-element)) + (< xmltok-start (point)))) + token-end) + ((nxml-scan-element-forward + (if (and (eq xmltok-type 'start-tag) + (= (point) xmltok-start)) + xmltok-start + token-end) + t)) + (t (error "No parent element"))))) + (setq arg (1- arg))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err)))))) + +(defun nxml-backward-up-element (&optional arg) + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-up-element (- arg)) + (condition-case err + (while (and (> arg 0) + (< (point-min) (point))) + (let ((token-end (nxml-token-before))) + (goto-char (cond ((or (memq xmltok-type '(start-tag + partial-start-tag)) + (and (memq xmltok-type + '(empty-element + partial-empty-element)) + (< (point) token-end))) + xmltok-start) + ((nxml-scan-element-backward + (if (and (eq xmltok-type 'end-tag) + (= (point) token-end)) + token-end + xmltok-start) + t) + xmltok-start) + (t (error "No parent element"))))) + (setq arg (1- arg))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err)))))) + +(defun nxml-down-element (&optional arg) + "Move forward down into the content of an element. +With ARG, do this that many times. +Negative ARG means move backward but still down." + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-backward-down-element (- arg)) + (while (> arg 0) + (goto-char + (let ((token-end (nxml-token-after))) + (save-excursion + (goto-char token-end) + (while (progn + (when (memq xmltok-type '(nil end-tag partial-end-tag)) + (error "No following start-tags in this element")) + (not (memq xmltok-type '(start-tag partial-start-tag)))) + (nxml-tokenize-forward)) + (point)))) + (setq arg (1- arg))))) + +(defun nxml-backward-down-element (&optional arg) + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-down-element (- arg)) + (while (> arg 0) + (goto-char + (save-excursion + (nxml-token-before) + (goto-char xmltok-start) + (while (progn + (when (memq xmltok-type '(start-tag + partial-start-tag + prolog + nil)) + (error "No preceding end-tags in this element")) + (not (memq xmltok-type '(end-tag partial-end-tag)))) + (if (or (<= (point) nxml-prolog-end) + (not (search-backward "<" nxml-prolog-end t))) + (setq xmltok-type nil) + (nxml-move-outside-backwards) + (xmltok-forward))) + xmltok-start)) + (setq arg (1- arg))))) + +(defun nxml-forward-element (&optional arg) + "Move forward over one element. +With ARG, do it that many times. +Negative ARG means move backward." + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-backward-element (- arg)) + (condition-case err + (while (and (> arg 0) + (< (point) (point-max))) + (goto-char + (or (nxml-scan-element-forward (nxml-token-before)) + (error "No more elements"))) + (setq arg (1- arg))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err)))))) + +(defun nxml-backward-element (&optional arg) + "Move backward over one element. +With ARG, do it that many times. +Negative ARG means move forward." + (interactive "p") + (or arg (setq arg 1)) + (if (< arg 0) + (nxml-forward-element (- arg)) + (condition-case err + (while (and (> arg 0) + (< (point-min) (point))) + (goto-char + (or (and (nxml-scan-element-backward (progn + (nxml-token-after) + xmltok-start)) + xmltok-start) + (error "No preceding elements"))) + (setq arg (1- arg))) + (nxml-scan-error + (goto-char (cadr err)) + (apply 'error (cddr err)))))) + +(defun nxml-mark-token-after () + (interactive) + (push-mark (nxml-token-after) nil t) + (goto-char xmltok-start) + (message "Marked %s" xmltok-type)) + +;;; Paragraphs + +(defun nxml-mark-paragraph () + "Put point at beginning of this paragraph, mark at end. +The paragraph marked is the one that contains point or follows point." + (interactive) + (nxml-forward-paragraph) + (push-mark nil t t) + (nxml-backward-paragraph)) + +(defun nxml-forward-paragraph (&optional arg) + (interactive "p") + (or arg (setq arg 1)) + (cond ((< arg 0) + (nxml-backward-paragraph (- arg))) + ((> arg 0) + (forward-line 0) + (while (and (nxml-forward-single-paragraph) + (> (setq arg (1- arg)) 0)))))) + +(defun nxml-backward-paragraph (&optional arg) + (interactive "p") + (or arg (setq arg 1)) + (cond ((< arg 0) + (nxml-forward-paragraph (- arg))) + ((> arg 0) + (unless (bolp) + (let ((inhibit-field-text-motion t)) + (end-of-line))) + (while (and (nxml-backward-single-paragraph) + (> (setq arg (1- arg)) 0)))))) + +(defun nxml-forward-single-paragraph () + "Move forward over a single paragraph. +Return nil at end of buffer, t otherwise." + (let* ((token-end (nxml-token-after)) + (offset (- (point) xmltok-start)) + pos had-data) + (goto-char token-end) + (while (and (< (point) (point-max)) + (not (setq pos + (nxml-paragraph-end-pos had-data offset)))) + (when (nxml-token-contains-data-p offset) + (setq had-data t)) + (nxml-tokenize-forward) + (setq offset 0)) + (when pos (goto-char pos)))) + +(defun nxml-backward-single-paragraph () + "Move backward over a single paragraph. +Return nil at start of buffer, t otherwise." + (let* ((token-end (nxml-token-before)) + (offset (- token-end (point))) + (last-tag-pos xmltok-start) + pos had-data last-data-pos) + (goto-char token-end) + (unless (setq pos (nxml-paragraph-start-pos nil offset)) + (setq had-data (nxml-token-contains-data-p nil offset)) + (goto-char xmltok-start) + (while (and (not pos) (< (point-min) (point))) + (cond ((search-backward "<" nxml-prolog-end t) + (nxml-move-outside-backwards) + (save-excursion + (while (< (point) last-tag-pos) + (xmltok-forward) + (when (and (not had-data) (nxml-token-contains-data-p)) + (setq pos nil) + (setq last-data-pos xmltok-start)) + (let ((tem (nxml-paragraph-start-pos had-data 0))) + (when tem (setq pos tem))))) + (when (and (not had-data) last-data-pos (not pos)) + (setq had-data t) + (save-excursion + (while (< (point) last-data-pos) + (xmltok-forward)) + (let ((tem (nxml-paragraph-start-pos had-data 0))) + (when tem (setq pos tem))))) + (setq last-tag-pos (point))) + (t (goto-char (point-min)))))) + (when pos (goto-char pos)))) + +(defun nxml-token-contains-data-p (&optional start end) + (setq start (+ xmltok-start (or start 0))) + (setq end (- (point) (or end 0))) + (when (eq xmltok-type 'cdata-section) + (setq start (max start (+ xmltok-start 9))) + (setq end (min end (- (point) 3)))) + (or (and (eq xmltok-type 'data) + (eq start xmltok-start) + (eq end (point))) + (eq xmltok-type 'char-ref) + (and (memq xmltok-type '(data cdata-section)) + (< start end) + (save-excursion + (goto-char start) + (re-search-forward "[^ \t\r\n]" end t))))) + +(defun nxml-paragraph-end-pos (had-data offset) + "Return the position of the paragraph end if contained in the current token. +Return nil if the current token does not contain the paragraph end. +Only characters after OFFSET from the start of the token are eligible. +HAD-DATA says whether there have been non-whitespace data characters yet." + (cond ((not had-data) + (cond ((memq xmltok-type '(data cdata-section)) + (save-excursion + (let ((end (point))) + (goto-char (+ xmltok-start + (max (if (eq xmltok-type 'cdata-section) + 9 + 0) + offset))) + (and (re-search-forward "[^ \t\r\n]" end t) + (re-search-forward "^[ \t]*$" end t) + (match-beginning 0))))) + ((and (eq xmltok-type 'comment) + (nxml-token-begins-line-p) + (nxml-token-ends-line-p)) + (save-excursion + (let ((end (point))) + (goto-char (+ xmltok-start (max 4 offset))) + (when (re-search-forward "[^ \t\r\n]" (- end 3) t) + (if (re-search-forward "^[ \t]*$" end t) + (match-beginning 0) + (goto-char (- end 3)) + (skip-chars-backward " \t") + (unless (bolp) + (beginning-of-line 2)) + (point)))))))) + ((memq xmltok-type '(data space cdata-section)) + (save-excursion + (let ((end (point))) + (goto-char (+ xmltok-start offset)) + (and (re-search-forward "^[ \t]*$" end t) + (match-beginning 0))))) + ((and (memq xmltok-type '(start-tag + end-tag + empty-element + comment + processing-instruction + entity-ref)) + (nxml-token-begins-line-p) + (nxml-token-ends-line-p)) + (save-excursion + (goto-char xmltok-start) + (skip-chars-backward " \t") + (point))) + ((and (eq xmltok-type 'end-tag) + (looking-at "[ \t]*$") + (not (nxml-in-mixed-content-p t))) + (save-excursion + (or (search-forward "\n" nil t) + (point-max)))))) + +(defun nxml-paragraph-start-pos (had-data offset) + "Return the position of the paragraph start if contained in the current token. +Return nil if the current token does not contain the paragraph start. +Only characters before OFFSET from the end of the token are eligible. +HAD-DATA says whether there have been non-whitespace data characters yet." + (cond ((not had-data) + (cond ((memq xmltok-type '(data cdata-section)) + (save-excursion + (goto-char (- (point) + (max (if (eq xmltok-type 'cdata-section) + 3 + 0) + offset))) + (and (re-search-backward "[^ \t\r\n]" xmltok-start t) + (re-search-backward "^[ \t]*$" xmltok-start t) + (match-beginning 0)))) + ((and (eq xmltok-type 'comment) + (nxml-token-ends-line-p) + (nxml-token-begins-line-p)) + (save-excursion + (goto-char (- (point) (max 3 offset))) + (when (and (< (+ xmltok-start 4) (point)) + (re-search-backward "[^ \t\r\n]" + (+ xmltok-start 4) + t)) + (if (re-search-backward "^[ \t]*$" xmltok-start t) + (match-beginning 0) + (goto-char xmltok-start) + (if (looking-at "<!--[ \t]*\n") + (match-end 0) + (skip-chars-backward " \t") + (point)))))))) + ((memq xmltok-type '(data space cdata-section)) + (save-excursion + (goto-char (- (point) offset)) + (and (re-search-backward "^[ \t]*$" xmltok-start t) + (match-beginning 0)))) + ((and (memq xmltok-type '(start-tag + end-tag + empty-element + comment + processing-instruction + entity-ref)) + (nxml-token-ends-line-p) + (nxml-token-begins-line-p)) + (or (search-forward "\n" nil t) + (point-max))) + ((and (eq xmltok-type 'start-tag) + (nxml-token-begins-line-p) + (not (save-excursion + (goto-char xmltok-start) + (nxml-in-mixed-content-p nil)))) + (save-excursion + (goto-char xmltok-start) + (skip-chars-backward " \t") + ;; include any blank line before + (or (and (eq (char-before) ?\n) + (save-excursion + (goto-char (1- (point))) + (skip-chars-backward " \t") + (and (bolp) (point)))) + (point)))))) + +(defun nxml-token-ends-line-p () (looking-at "[ \t]*$")) + +(defun nxml-token-begins-line-p () + (save-excursion + (goto-char xmltok-start) + (skip-chars-backward " \t") + (bolp))) + +(defun nxml-in-mixed-content-p (endp) + "Return non-nil if point is in mixed content. +Point must be after an end-tag or before a start-tag. +ENDP is t in the former case, nil in the latter." + (let (matching-tag-pos) + (cond ((not (run-hook-with-args-until-failure + 'nxml-in-mixed-content-hook)) + nil) + ;; See if the matching tag does not start or end a line. + ((condition-case err + (progn + (setq matching-tag-pos + (xmltok-save + (if endp + (and (nxml-scan-element-backward (point)) + xmltok-start) + (nxml-scan-element-forward (point))))) + (and matching-tag-pos + (save-excursion + (goto-char matching-tag-pos) + (not (if endp + (progn + (skip-chars-backward " \t") + (bolp)) + (looking-at "[ \t]*$")))))) + (nxml-scan-error nil)) + t) + ;; See if there's data at the same level. + ((let (start end) + (if endp + (setq start matching-tag-pos + end (point)) + (setq start (point) + end matching-tag-pos)) + (save-excursion + (or (when start + (goto-char start) + (nxml-preceding-sibling-data-p)) + (when end + (goto-char end) + (nxml-following-sibling-data-p))))) + t) + ;; Otherwise, treat as not mixed + (t nil)))) + +(defun nxml-preceding-sibling-data-p () + "Return non-nil if there is a previous sibling that is data." + (let ((lim (max (- (point) nxml-mixed-scan-distance) + nxml-prolog-end)) + (level 0) + found end) + (xmltok-save + (save-excursion + (while (and (< lim (point)) + (>= level 0) + (not found) + (progn + (setq end (point)) + (search-backward "<" lim t))) + (nxml-move-outside-backwards) + (save-excursion + (xmltok-forward) + (let ((prev-level level)) + (cond ((eq xmltok-type 'end-tag) + (setq level (1+ level))) + ((eq xmltok-type 'start-tag) + (setq level (1- level)))) + (when (eq prev-level 0) + (while (and (< (point) end) (not found)) + (xmltok-forward) + (when (memq xmltok-type '(data cdata-section char-ref)) + (setq found t))))))))) + found)) + +(defun nxml-following-sibling-data-p () + (let ((lim (min (+ (point) nxml-mixed-scan-distance) + (point-max))) + (level 0) + found) + (xmltok-save + (save-excursion + (while (and (< (point) lim) + (>= level 0) + (nxml-tokenize-forward) + (not found)) + (cond ((eq xmltok-type 'start-tag) + (setq level (1+ level))) + ((eq xmltok-type 'end-tag) + (setq level (1- level))) + ((and (eq level 0) + (memq xmltok-type '(data cdata-section char-ref))) + (setq found t)))))) + found)) + +;;; Filling + +(defun nxml-do-fill-paragraph (arg) + (let (fill-paragraph-function + fill-prefix + start end) + (save-excursion + (nxml-forward-paragraph) + (setq end (point)) + (nxml-backward-paragraph) + (skip-chars-forward " \t\r\n") + (setq start (point)) + (beginning-of-line) + (setq fill-prefix (buffer-substring-no-properties (point) start)) + (when (and (not (nxml-get-inside (point))) + (looking-at "[ \t]*<!--")) + (setq fill-prefix (concat fill-prefix " "))) + (fill-region-as-paragraph start end arg)) + (skip-line-prefix fill-prefix) + fill-prefix)) + +(defun nxml-newline-and-indent (soft) + (delete-horizontal-space) + (if soft (insert-and-inherit ?\n) (newline 1)) + (nxml-indent-line)) + + +;;; Dynamic markup + +(defvar nxml-dynamic-markup-prev-pos nil) +(defvar nxml-dynamic-markup-prev-lengths nil) +(defvar nxml-dynamic-markup-prev-found-marker nil) +(defvar nxml-dynamic-markup-prev-start-tags (make-hash-table :test 'equal)) + +(defun nxml-dynamic-markup-word () + "Dynamically markup the word before point. +This attempts to find a tag to put around the word before point based +on the contents of the current buffer. The end-tag will be inserted at +point. The start-tag will be inserted at or before the beginning of +the word before point; the contents of the current buffer is used to +decide where. + +It works in a similar way to \\[dabbrev-expand]. It searches first +backwards from point, then forwards from point for an element whose +content is a string which matches the contents of the buffer before +point and which includes at least the word before point. It then +copies the start- and end-tags from that element and uses them to +surround the matching string before point. + +Repeating \\[nxml-dynamic-markup-word] immediately after successful +\\[nxml-dynamic-markup-word] removes the previously inserted markup +and attempts to find another possible way to do the markup." + (interactive "*") + (let (search-start-pos done) + (if (and (integerp nxml-dynamic-markup-prev-pos) + (= nxml-dynamic-markup-prev-pos (point)) + (eq last-command this-command) + nxml-dynamic-markup-prev-lengths) + (let* ((end-tag-open-pos + (- nxml-dynamic-markup-prev-pos + (nth 2 nxml-dynamic-markup-prev-lengths))) + (start-tag-close-pos + (- end-tag-open-pos + (nth 1 nxml-dynamic-markup-prev-lengths))) + (start-tag-open-pos + (- start-tag-close-pos + (nth 0 nxml-dynamic-markup-prev-lengths)))) + (delete-region end-tag-open-pos nxml-dynamic-markup-prev-pos) + (delete-region start-tag-open-pos start-tag-close-pos) + (setq search-start-pos + (marker-position nxml-dynamic-markup-prev-found-marker))) + (clrhash nxml-dynamic-markup-prev-start-tags)) + (setq nxml-dynamic-markup-prev-pos nil) + (setq nxml-dynamic-markup-prev-lengths nil) + (setq nxml-dynamic-markup-prev-found-marker nil) + (goto-char + (save-excursion + (let* ((pos (point)) + (word (progn + (backward-word 1) + (unless (< (point) pos) + (error "No word to markup")) + (buffer-substring-no-properties (point) pos))) + (search (concat word "</")) + done) + (when search-start-pos + (goto-char search-start-pos)) + (while (and (not done) + (or (and (< (point) pos) + (or (search-backward search nil t) + (progn (goto-char pos) nil))) + (search-forward search nil t))) + (goto-char (- (match-end 0) 2)) + (setq done (nxml-try-copy-markup pos))) + (or done + (error (if (zerop (hash-table-count + nxml-dynamic-markup-prev-start-tags)) + "No possible markup found for `%s'" + "No more markup possibilities found for `%s'") + word))))))) + +(defun nxml-try-copy-markup (word-end-pos) + (save-excursion + (let ((end-tag-pos (point))) + (when (and (not (nxml-get-inside end-tag-pos)) + (search-backward "<" nil t) + (not (nxml-get-inside (point)))) + (xmltok-forward) + (when (and (eq xmltok-type 'start-tag) + (< (point) end-tag-pos)) + (let* ((start-tag-close-pos (point)) + (start-tag + (buffer-substring-no-properties xmltok-start + start-tag-close-pos)) + (words + (nreverse + (split-string + (buffer-substring-no-properties start-tag-close-pos + end-tag-pos) + "[ \t\r\n]+")))) + (goto-char word-end-pos) + (while (and words + (re-search-backward (concat + (regexp-quote (car words)) + "\\=") + nil + t)) + (setq words (cdr words)) + (skip-chars-backward " \t\r\n")) + (when (and (not words) + (progn + (skip-chars-forward " \t\r\n") + (not (gethash (cons (point) start-tag) + nxml-dynamic-markup-prev-start-tags))) + (or (< end-tag-pos (point)) + (< word-end-pos xmltok-start))) + (setq nxml-dynamic-markup-prev-found-marker + (copy-marker end-tag-pos t)) + (puthash (cons (point) start-tag) + t + nxml-dynamic-markup-prev-start-tags) + (setq nxml-dynamic-markup-prev-lengths + (list (- start-tag-close-pos xmltok-start) + (- word-end-pos (point)) + (+ (- xmltok-name-end xmltok-start) 2))) + (let ((name (xmltok-start-tag-qname))) + (insert start-tag) + (goto-char (+ word-end-pos + (- start-tag-close-pos xmltok-start))) + (insert "</" name ">") + (setq nxml-dynamic-markup-prev-pos (point)))))))))) + + +;;; Character names + +(defvar nxml-char-name-ignore-case nil) + +(defvar nxml-char-name-alist nil + "Alist of character names. +Each member of the list has the form (NAME CODE . NAMESET), +where NAME is a string naming a character, NAMESET is a symbol +identifying a set of names and CODE is an integer specifying the +Unicode scalar value of the named character. +The NAME will only be used for completion if NAMESET has +a non-nil `nxml-char-name-set-enabled' property. +If NAMESET does does not have `nxml-char-name-set-defined' property, +then it must have a `nxml-char-name-set-file' property and `load' +will be applied to the value of this property if the nameset +is enabled.") + +(defvar nxml-char-name-table (make-hash-table :test 'eq) + "Hash table for mapping char codes to names. +Each key is a Unicode scalar value. +Each value is a list of pairs of the form (NAMESET . NAME), +where NAMESET is a symbol identifying a set of names, +and NAME is a string naming a character.") + +(defvar nxml-autoload-char-name-set-list nil + "List of char namesets that can be autoloaded.") + +(defun nxml-enable-char-name-set (nameset) + (put nameset 'nxml-char-name-set-enabled t)) + +(defun nxml-disable-char-name-set (nameset) + (put nameset 'nxml-char-name-set-enabled nil)) + +(defun nxml-char-name-set-enabled-p (nameset) + (get nameset 'nxml-char-name-set-enabled)) + +(defun nxml-autoload-char-name-set (nameset file) + (unless (memq nameset nxml-autoload-char-name-set-list) + (setq nxml-autoload-char-name-set-list + (cons nameset nxml-autoload-char-name-set-list))) + (put nameset 'nxml-char-name-set-file file)) + +(defun nxml-define-char-name-set (nameset alist) + "Define a set of character names. +NAMESET is a symbol identifying the set. +Alist is a list where each member has the form (NAME CODE), +where NAME is a string naming a character and code +is an integer giving the Unicode scalar value of the character." + (when (get nameset 'nxml-char-name-set-defined) + (error "Nameset `%s' already defined" nameset)) + (let ((iter alist)) + (while iter + (let* ((name-code (car iter)) + (name (car name-code)) + (code (cadr name-code))) + (puthash code + (cons (cons nameset name) + (gethash code nxml-char-name-table)) + nxml-char-name-table)) + (setcdr (cdr (car iter)) nameset) + (setq iter (cdr iter)))) + (setq nxml-char-name-alist + (nconc alist nxml-char-name-alist)) + (put nameset 'nxml-char-name-set-defined t)) + +(defun nxml-get-char-name (code) + (mapc 'nxml-maybe-load-char-name-set nxml-autoload-char-name-set-list) + (let ((names (gethash code nxml-char-name-table)) + name) + (while (and names (not name)) + (if (nxml-char-name-set-enabled-p (caar names)) + (setq name (cdar names)) + (setq names (cdr names)))) + name)) + +(defvar nxml-named-char-history nil) + +(defun nxml-insert-named-char (arg) + "Insert a character using its name. +The name is read from the minibuffer. +Normally, inserts the character as a numeric character reference. +With a prefix argument, inserts the character directly." + (interactive "*P") + (mapc 'nxml-maybe-load-char-name-set nxml-autoload-char-name-set-list) + (let ((name + (let ((completion-ignore-case nxml-char-name-ignore-case)) + (completing-read "Character name: " + nxml-char-name-alist + (lambda (member) + (get (cddr member) 'nxml-char-name-set-enabled)) + t + nil + 'nxml-named-char-history))) + (alist nxml-char-name-alist) + elt code) + (while (and alist (not code)) + (setq elt (assoc name alist)) + (if (get (cddr elt) 'nxml-char-name-set-enabled) + (setq code (cadr elt)) + (setq alist (cdr (member elt alist))))) + (when code + (insert (if arg + (or (decode-char 'ucs code) + (error "Character %x is not supported by Emacs" + code)) + (format "&#x%X;" code)))))) + +(defun nxml-maybe-load-char-name-set (sym) + (when (and (get sym 'nxml-char-name-set-enabled) + (not (get sym 'nxml-char-name-set-defined)) + (stringp (get sym 'nxml-char-name-set-file))) + (load (get sym 'nxml-char-name-set-file)))) + +(defun nxml-toggle-char-ref-extra-display (arg) + "*Toggle the display of extra information for character references." + (interactive "P") + (let ((new (if (null arg) + (not nxml-char-ref-extra-display) + (> (prefix-numeric-value arg) 0)))) + (when (not (eq new nxml-char-ref-extra-display)) + (setq nxml-char-ref-extra-display new) + (save-excursion + (save-restriction + (widen) + (if nxml-char-ref-extra-display + (nxml-with-unmodifying-text-property-changes + (nxml-clear-fontified (point-min) (point-max))) + (nxml-clear-char-ref-extra-display (point-min) (point-max)))))))) + +(put 'nxml-char-ref 'evaporate t) + +(defun nxml-char-ref-display-extra (start end n) + (when nxml-char-ref-extra-display + (let ((name (nxml-get-char-name n)) + (glyph-string (and nxml-char-ref-display-glyph-flag + (nxml-glyph-display-string n 'nxml-glyph-face))) + ov) + (when (or name glyph-string) + (setq ov (make-overlay start end nil t)) + (overlay-put ov 'category 'nxml-char-ref) + (when name + (overlay-put ov 'help-echo name)) + (when glyph-string + (overlay-put ov + 'after-string + (propertize glyph-string 'face 'nxml-glyph-face))))))) + +(defun nxml-clear-char-ref-extra-display (start end) + (let ((ov (overlays-in start end))) + (while ov + (when (eq (overlay-get (car ov) 'category) 'nxml-char-ref) + (delete-overlay (car ov))) + (setq ov (cdr ov))))) + +;;; Versioning + +(defun nxml-version () + "Show the version of nXML mode that is being used." + (interactive) + (if nxml-version + (message "nXML mode version %s" nxml-version) + (message "nXML mode version unknown"))) + + +(defun nxml-start-delimiter-length (type) + (or (get type 'nxml-start-delimiter-length) + 0)) + +(put 'cdata-section 'nxml-start-delimiter-length 9) +(put 'comment 'nxml-start-delimiter-length 4) +(put 'processing-instruction 'nxml-start-delimiter-length 2) +(put 'start-tag 'nxml-start-delimiter-length 1) +(put 'empty-element 'nxml-start-delimiter-length 1) +(put 'partial-empty-element 'nxml-start-delimiter-length 1) +(put 'entity-ref 'nxml-start-delimiter-length 1) +(put 'char-ref 'nxml-start-delimiter-length 2) + +(defun nxml-end-delimiter-length (type) + (or (get type 'nxml-end-delimiter-length) + 0)) + +(put 'cdata-section 'nxml-end-delimiter-length 3) +(put 'comment 'nxml-end-delimiter-length 3) +(put 'processing-instruction 'nxml-end-delimiter-length 2) +(put 'start-tag 'nxml-end-delimiter-length 1) +(put 'empty-element 'nxml-end-delimiter-length 2) +(put 'partial-empty-element 'nxml-end-delimiter-length 1) +(put 'entity-ref 'nxml-end-delimiter-length 1) +(put 'char-ref 'nxml-end-delimiter-length 1) + +(defun nxml-token-type-friendly-name (type) + (or (get type 'nxml-friendly-name) + (symbol-name type))) + +(put 'cdata-section 'nxml-friendly-name "CDATA section") +(put 'processing-instruction 'nxml-friendly-name "processing instruction") +(put 'entity-ref 'nxml-friendly-name "entity reference") +(put 'char-ref 'nxml-friendly-name "character reference") + +(provide 'nxml-mode) + +;; arch-tag: 8603bc5f-1ef9-4021-b223-322fb2ca708e +;;; nxml-mode.el ends here diff --git a/lisp/nxml/nxml-ns.el b/lisp/nxml/nxml-ns.el new file mode 100644 index 00000000000..0d1b1543b45 --- /dev/null +++ b/lisp/nxml/nxml-ns.el @@ -0,0 +1,151 @@ +;;; nxml-ns.el --- XML namespace processing + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file uses a prefix of `nxml-ns'. + +;;; Code: + +(require 'nxml-util) + +(defvar nxml-ns-state nil + "Contains the state of namespace processing. The state +is never modified destructively and so can be saved and restored +without copying. + +The value is a stack represented by a list. The list has length N + 1 +where N is the number of open elements. Each member of the list +represents the bindings in effect for a particular element. Each +member is itself a list whose car is the default namespace +\(a symbol or nil) and whose cdr is an alist of (PREFIX . NS) pairs +where PREFIX is a string (never nil) and NS is the namespace URI +symbol.") + +(defconst nxml-ns-initial-state + (list (list nil (cons "xml" nxml-xml-namespace-uri))) + "A list to be used as the initial value of nxml-ns-state. This +represents the state with no open elements and with the default +namespace bindings (no default namespace and only the xml prefix bound).") + +(defsubst nxml-ns-state () nxml-ns-state) + +(defsubst nxml-ns-set-state (state) + (setq nxml-ns-state state)) + +(defsubst nxml-ns-state-equal (state) + (equal nxml-ns-state state)) + +(defmacro nxml-ns-save (&rest body) + `(let ((nxml-ns-state nxml-ns-initial-state)) + ,@body)) + +(put 'nxml-ns-save 'lisp-indent-function 0) +(def-edebug-spec nxml-ns-save t) + +(defun nxml-ns-init () + (setq nxml-ns-state nxml-ns-initial-state)) + +(defun nxml-ns-push-state () + "Change the state by starting a new element. Namespace declarations +are inherited from the parent state." + (setq nxml-ns-state (cons (car nxml-ns-state) nxml-ns-state))) + +(defun nxml-ns-pop-state () + "Change the state by ending an element. The behaviour is undefined +if there is no open element." + (setq nxml-ns-state (cdr nxml-ns-state))) + +(defun nxml-ns-get-prefix (prefix) + "Return the symbol for namespace bound to PREFIX, or nil if PREFIX +is unbound. PREFIX is a string, never nil." + (let ((binding (assoc prefix (cdar nxml-ns-state)))) + (and binding (cdr binding)))) + +(defun nxml-ns-set-prefix (prefix ns) + "Change the binding of PREFIX. PREFIX is a string (never nil). NS +is a symbol (never nil). The change will be in effect until the end of +the current element." + (setq nxml-ns-state + (let ((bindings (car nxml-ns-state))) + (cons (cons (car bindings) + (cons (cons prefix ns) (cdr bindings))) + (cdr nxml-ns-state))))) + +(defun nxml-ns-get-default () + "Return the current default namespace as a symbol, or nil +if there is no default namespace." + (caar nxml-ns-state)) + +(defun nxml-ns-set-default (ns) + "Changes the current default namespace. The change +will be in effect until the end of the current element. +NS is a symbol or nil." + (setq nxml-ns-state + (cons (cons ns (cdar nxml-ns-state)) + (cdr nxml-ns-state)))) + +(defun nxml-ns-get-context () + (car nxml-ns-state)) + +(defun nxml-ns-prefixes-for (ns &optional attributep) + (let ((current (car nxml-ns-state)) + prefixes) + (when (if attributep + (not ns) + (eq (car current) ns)) + (setq prefixes '(nil))) + (setq current (cdr current)) + (while (let ((binding (rassq ns current))) + (when binding + (when (eq (nxml-ns-get-prefix (car binding)) ns) + (add-to-list 'prefixes + (car binding))) + (setq current + (cdr (member binding current)))))) + prefixes)) + +(defun nxml-ns-prefix-for (ns) + (car (rassq ns (cdar nxml-ns-state)))) + +(defun nxml-ns-changed-prefixes () + (let ((old (cadr nxml-ns-state)) + (new (car nxml-ns-state)) + changed) + (if (eq old new) + nil + (unless (eq (car new) (car old)) + (setq changed '(nil))) + (setq new (cdr new)) + (setq old (cdr old)) + (while (not (eq new old)) + (setq changed + (cons (caar new) changed)) + (setq new (cdr new)))) + changed)) + +(provide 'nxml-ns) + +;; arch-tag: 5968e4b7-fb37-46ce-8621-c65db9793028 +;;; nxml-ns.el ends here diff --git a/lisp/nxml/nxml-outln.el b/lisp/nxml/nxml-outln.el new file mode 100644 index 00000000000..841e0e70146 --- /dev/null +++ b/lisp/nxml/nxml-outln.el @@ -0,0 +1,1043 @@ +;;; nxml-outln.el --- outline support for nXML mode + +;; Copyright (C) 2004, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; A section can be in one of three states +;; 1. display normally; this displays each child section +;; according to its state; anything not part of child sections is also +;; displayed normally +;; 2. display just the title specially; child sections are not displayed +;; regardless of their state; anything not part of child sections is +;; not displayed +;; 3. display the title specially and display child sections +;; according to their state; anything not part of the child section is +;; not displayed +;; The state of a section is determined by the value of the +;; nxml-outline-state text property of the < character that starts +;; the section. +;; For state 1 the value is nil or absent. +;; For state 2 it is the symbol hide-children. +;; For state 3 it is t. +;; The special display is achieved by using overlays. The overlays +;; are computed from the nxml-outline-state property by +;; `nxml-refresh-outline'. There overlays all have a category property +;; with an nxml-outline-display property with value t. +;; +;; For a section to be recognized as such, the following conditions must +;; be satisfied: +;; - its start-tag must occur at the start of a line (possibly indented) +;; - its local name must match `nxml-section-element-name-regexp' +;; - it must have a heading element; a heading element is an +;; element whose name matches `nxml-heading-element-name-regexp', +;; and that occurs as, or as a descendant of, the first child element +;; of the section +;; +;; XXX What happens if an nxml-outline-state property is attached to a +;; character that doesn't start a section element? +;; +;; An outlined section (an section with a non-nil nxml-outline-state +;; property) can be displayed in either single-line or multi-line +;; form. Single-line form is used when the outline state is hide-children +;; or there are no child sections; multi-line form is used otherwise. +;; There are two flavors of single-line form: with children and without. +;; The with-childen flavor is used when there are child sections. +;; Single line with children looks like +;; <+section>A section title...</> +;; Single line without children looks like +;; <-section>A section title...</> +;; Multi line looks likes +;; <-section>A section title... +;; [child sections displayed here] +;; </-section> +;; The indent of an outlined section is computed relative to the +;; outermost containing outlined element. The indent of the +;; outermost containing element comes from the non-outlined +;; indent of the section start-tag. + +;;; Code: + +(require 'xmltok) +(require 'nxml-util) +(require 'nxml-rap) + +(defcustom nxml-section-element-name-regexp + "article\\|\\(sub\\)*section\\|chapter\\|div\\|appendix\\|part\\|preface\\|reference\\|simplesect\\|bibliography\\|bibliodiv\\|glossary\\|glossdiv" + "*Regular expression matching the name of elements used as sections. +An XML element is treated as a section if: + +- its local name (that is, the name without the prefix) matches +this regexp; + +- either its first child element or a descendant of that first child +element has a local name matching the variable +`nxml-heading-element-name-regexp'; and + +- its start-tag occurs at the beginning of a line (possibly indented)." + :group 'nxml + :type 'regexp) + +(defcustom nxml-heading-element-name-regexp "title\\|head" + "*Regular expression matching the name of elements used as headings. +An XML element is only recognized as a heading if it occurs as or +within the first child of an element that is recognized as a section. +See the variable `nxml-section-element-name-regexp' for more details." + :group 'nxml + :type 'regexp) + +(defcustom nxml-outline-child-indent 2 + "*Indentation in an outline for child element relative to parent element." + :group 'nxml + :type 'integer) + +(defface nxml-heading-face + '((t (:weight bold))) + "Face used for the contents of abbreviated heading elements." + :group 'nxml-highlighting-faces) + +(defface nxml-outline-indicator-face + '((t (:inherit default))) + "Face used for `+' or `-' before element names in outlines." + :group 'nxml-highlighting-faces) + +(defface nxml-outline-active-indicator-face + '((t (:box t :inherit nxml-outline-indicator-face))) + "Face used for clickable `+' or `-' before element names in outlines." + :group 'nxml-highlighting-faces) + +(defface nxml-outline-ellipsis-face + '((t (:bold t :inherit default))) + "Face used for `...' in outlines." + :group 'nxml-highlighting-faces) + +(defvar nxml-heading-scan-distance 1000 + "Maximum distance from section to scan for heading.") + +(defvar nxml-outline-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-a" 'nxml-show-all) + (define-key map "\C-t" 'nxml-hide-all-text-content) + (define-key map "\C-r" 'nxml-refresh-outline) + (define-key map "\C-c" 'nxml-hide-direct-text-content) + (define-key map "\C-e" 'nxml-show-direct-text-content) + (define-key map "\C-d" 'nxml-hide-subheadings) + (define-key map "\C-s" 'nxml-show) + (define-key map "\C-k" 'nxml-show-subheadings) + (define-key map "\C-l" 'nxml-hide-text-content) + (define-key map "\C-i" 'nxml-show-direct-subheadings) + (define-key map "\C-o" 'nxml-hide-other) + map)) + +;;; Commands for changing visibility + +(defun nxml-show-all () + "Show all elements in the buffer normally." + (interactive) + (nxml-with-unmodifying-text-property-changes + (remove-text-properties (point-min) + (point-max) + '(nxml-outline-state nil))) + (nxml-outline-set-overlay nil (point-min) (point-max))) + +(defun nxml-hide-all-text-content () + "Hide all text content in the buffer. +Anything that is in a section but is not a heading will be hidden. +The visibility of headings at any level will not be changed. See the +variable `nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (nxml-transform-buffer-outline '((nil . t)))) + +(defun nxml-show-direct-text-content () + "Show the text content that is directly part of the section containing point. +Each subsection will be shown according to its individual state, which +will not be changed. The section containing point is the innermost +section that contains the character following point. See the variable +`nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (nxml-outline-pre-adjust-point) + (nxml-set-outline-state (nxml-section-start-position) nil) + (nxml-refresh-outline) + (nxml-outline-adjust-point)) + +(defun nxml-show-direct-subheadings () + "Show the immediate subheadings of the section containing point. +The section containing point is the innermost section that contains +the character following point. See the variable +`nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (let ((pos (nxml-section-start-position))) + (when (eq (nxml-get-outline-state pos) 'hide-children) + (nxml-set-outline-state pos t))) + (nxml-refresh-outline) + (nxml-outline-adjust-point)) + +(defun nxml-hide-direct-text-content () + "Hide the text content that is directly part of the section containing point. +The heading of the section will remain visible. The state of +subsections will not be changed. The section containing point is the +innermost section that contains the character following point. See the +variable `nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (let ((pos (nxml-section-start-position))) + (when (null (nxml-get-outline-state pos)) + (nxml-set-outline-state pos t))) + (nxml-refresh-outline) + (nxml-outline-adjust-point)) + +(defun nxml-hide-subheadings () + "Hide the subheadings that are part of the section containing point. +The text content will also be hidden, leaving only the heading of the +section itself visible. The state of the subsections will also be +changed to hide their headings, so that \\[nxml-show-direct-text-content] +would show only the heading of the subsections. The section containing +point is the innermost section that contains the character following +point. See the variable `nxml-section-element-name-regexp' for more +details on how to customize which elements are recognized as sections +and headings." + (interactive) + (nxml-transform-subtree-outline '((nil . hide-children) + (t . hide-children)))) + +(defun nxml-show () + "Show the section containing point normally, without hiding anything. +This includes everything in the section at any level. The section +containing point is the innermost section that contains the character +following point. See the variable `nxml-section-element-name-regexp' +for more details on how to customize which elements are recognized as +sections and headings." + (interactive) + (nxml-transform-subtree-outline '((hide-children . nil) + (t . nil)))) + +(defun nxml-hide-text-content () + "Hide text content at all levels in the section containing point. +The section containing point is the innermost section that contains +the character following point. See the variable +`nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (nxml-transform-subtree-outline '((nil . t)))) + +(defun nxml-show-subheadings () + "Show the subheadings at all levels of the section containing point. +The visibility of the text content at all levels in the section is not +changed. The section containing point is the innermost section that +contains the character following point. See the variable +`nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (nxml-transform-subtree-outline '((hide-children . t)))) + +(defun nxml-hide-other () + "Hide text content other than that directly in the section containing point. +Hide headings other than those of ancestors of that section and their +immediate subheadings. The section containing point is the innermost +section that contains the character following point. See the variable +`nxml-section-element-name-regexp' for more details on how to +customize which elements are recognized as sections and headings." + (interactive) + (let ((nxml-outline-state-transform-exceptions nil)) + (save-excursion + (while (and (condition-case err + (nxml-back-to-section-start) + (nxml-outline-error (nxml-report-outline-error + "Couldn't find containing section: %s" + err))) + (progn + (when (and nxml-outline-state-transform-exceptions + (null (nxml-get-outline-state (point)))) + (nxml-set-outline-state (point) t)) + (setq nxml-outline-state-transform-exceptions + (cons (point) + nxml-outline-state-transform-exceptions)) + (< nxml-prolog-end (point)))) + (goto-char (1- (point))))) + (nxml-transform-buffer-outline '((nil . hide-children) + (t . hide-children))))) + +;; These variables are dynamically bound. They are use to pass information to +;; nxml-section-tag-transform-outline-state. + +(defvar nxml-outline-state-transform-exceptions nil) +(defvar nxml-target-section-pos nil) +(defvar nxml-depth-in-target-section nil) +(defvar nxml-outline-state-transform-alist nil) + +(defun nxml-transform-buffer-outline (alist) + (let ((nxml-target-section-pos nil) + (nxml-depth-in-target-section 0) + (nxml-outline-state-transform-alist alist) + (nxml-outline-display-section-tag-function + 'nxml-section-tag-transform-outline-state)) + (nxml-refresh-outline)) + (nxml-outline-adjust-point)) + +(defun nxml-transform-subtree-outline (alist) + (let ((nxml-target-section-pos (nxml-section-start-position)) + (nxml-depth-in-target-section nil) + (nxml-outline-state-transform-alist alist) + (nxml-outline-display-section-tag-function + 'nxml-section-tag-transform-outline-state)) + (nxml-refresh-outline)) + (nxml-outline-adjust-point)) + +(defun nxml-outline-pre-adjust-point () + (cond ((and (< (point-min) (point)) + (get-char-property (1- (point)) 'invisible) + (not (get-char-property (point) 'invisible)) + (let ((str (or (get-char-property (point) 'before-string) + (get-char-property (point) 'display)))) + (and (stringp str) + (>= (length str) 3) + (string= (substring str 0 3) "...")))) + ;; The ellipsis is a display property on a visible character + ;; following an invisible region. The position of the event + ;; will be the position before that character. We want to + ;; move point to the other side of the invisible region, i.e. + ;; following the last visible character before that invisible + ;; region. + (goto-char (previous-single-char-property-change (1- (point)) + 'invisible))) + ((and (< (point) (point-max)) + (get-char-property (point) 'display) + (get-char-property (1+ (point)) 'invisible)) + (goto-char (next-single-char-property-change (1+ (point)) + 'invisible))) + ((and (< (point) (point-max)) + (get-char-property (point) 'invisible)) + (goto-char (next-single-char-property-change (point) + 'invisible))))) + +(defun nxml-outline-adjust-point () + "Adjust point after showing or hiding elements." + (when (and (get-char-property (point) 'invisible) + (< (point-min) (point)) + (get-char-property (1- (point)) 'invisible)) + (goto-char (previous-single-char-property-change (point) + 'invisible + nil + nxml-prolog-end)))) + +(defun nxml-transform-outline-state (section-start-pos) + (let* ((old-state + (nxml-get-outline-state section-start-pos)) + (change (assq old-state + nxml-outline-state-transform-alist))) + (when change + (nxml-set-outline-state section-start-pos + (cdr change))))) + +(defun nxml-section-tag-transform-outline-state (startp + section-start-pos + &optional + heading-start-pos) + (if (not startp) + (setq nxml-depth-in-target-section + (and nxml-depth-in-target-section + (> nxml-depth-in-target-section 0) + (1- nxml-depth-in-target-section))) + (cond (nxml-depth-in-target-section + (setq nxml-depth-in-target-section + (1+ nxml-depth-in-target-section))) + ((= section-start-pos nxml-target-section-pos) + (setq nxml-depth-in-target-section 0))) + (when (and nxml-depth-in-target-section + (not (member section-start-pos + nxml-outline-state-transform-exceptions))) + (nxml-transform-outline-state section-start-pos)))) + +(defun nxml-get-outline-state (pos) + (get-text-property pos 'nxml-outline-state)) + +(defun nxml-set-outline-state (pos state) + (nxml-with-unmodifying-text-property-changes + (if state + (put-text-property pos (1+ pos) 'nxml-outline-state state) + (remove-text-properties pos (1+ pos) '(nxml-outline-state nil))))) + +;;; Mouse interface + +(defun nxml-mouse-show-direct-text-content (event) + "Do the same as \\[nxml-show-direct-text-content] from a mouse click." + (interactive "e") + (and (nxml-mouse-set-point event) + (nxml-show-direct-text-content))) + +(defun nxml-mouse-hide-direct-text-content (event) + "Do the same as \\[nxml-hide-direct-text-content] from a mouse click." + (interactive "e") + (and (nxml-mouse-set-point event) + (nxml-hide-direct-text-content))) + +(defun nxml-mouse-hide-subheadings (event) + "Do the same as \\[nxml-hide-subheadings] from a mouse click." + (interactive "e") + (and (nxml-mouse-set-point event) + (nxml-hide-subheadings))) + +(defun nxml-mouse-show-direct-subheadings (event) + "Do the same as \\[nxml-show-direct-subheadings] from a mouse click." + (interactive "e") + (and (nxml-mouse-set-point event) + (nxml-show-direct-subheadings))) + +(defun nxml-mouse-set-point (event) + (mouse-set-point event) + (and nxml-prolog-end t)) + +;; Display + +(defsubst nxml-token-start-tag-p () + (or (eq xmltok-type 'start-tag) + (eq xmltok-type 'partial-start-tag))) + +(defsubst nxml-token-end-tag-p () + (or (eq xmltok-type 'end-tag) + (eq xmltok-type 'partial-end-tag))) + +(defun nxml-refresh-outline () + "Refresh the outline to correspond to the current XML element structure." + (interactive) + (save-excursion + (goto-char (point-min)) + (kill-local-variable 'line-move-ignore-invisible) + (make-local-variable 'line-move-ignore-invisible) + (condition-case err + (nxml-outline-display-rest nil nil nil) + (nxml-outline-error + (nxml-report-outline-error "Cannot display outline: %s" err))))) + +(defvar nxml-outline-display-section-tag-function nil) + +(defun nxml-outline-display-rest (outline-state start-tag-indent tag-qnames) + "Display up to and including the end of the current element. +OUTLINE-STATE can be nil, t, hide-children. START-TAG-INDENT is the +indent of the start-tag of the current element, or nil if no +containing element has a non-nil OUTLINE-STATE. TAG-QNAMES is a list +of the qnames of the open elements. Point is after the title content. +Leave point after the closing end-tag Return t if we had a +non-transparent child section." + (let ((last-pos (point)) + (transparent-depth 0) + ;; don't want ellipsis before root element + (had-children (not tag-qnames))) + (while + (cond ((not (nxml-section-tag-forward)) + (if (null tag-qnames) + nil + (nxml-outline-error "missing end-tag %s" + (car tag-qnames)))) + ;; section end-tag + ((nxml-token-end-tag-p) + (when nxml-outline-display-section-tag-function + (funcall nxml-outline-display-section-tag-function + nil + xmltok-start)) + (let ((qname (xmltok-end-tag-qname))) + (unless tag-qnames + (nxml-outline-error "extra end-tag %s" qname)) + (unless (string= (car tag-qnames) qname) + (nxml-outline-error "mismatched end-tag; expected %s, got %s" + (car tag-qnames) + qname))) + (cond ((> transparent-depth 0) + (setq transparent-depth (1- transparent-depth)) + (setq tag-qnames (cdr tag-qnames)) + t) + ((not outline-state) + (nxml-outline-set-overlay nil last-pos (point)) + nil) + ((or (not had-children) + (eq outline-state 'hide-children)) + (nxml-outline-display-single-line-end-tag last-pos) + nil) + (t + (nxml-outline-display-multi-line-end-tag last-pos + start-tag-indent) + nil))) + ;; section start-tag + (t + (let* ((qname (xmltok-start-tag-qname)) + (section-start-pos xmltok-start) + (heading-start-pos + (and (or nxml-outline-display-section-tag-function + (not (eq outline-state 'had-children)) + (not had-children)) + (nxml-token-starts-line-p) + (nxml-heading-start-position)))) + (when nxml-outline-display-section-tag-function + (funcall nxml-outline-display-section-tag-function + t + section-start-pos + heading-start-pos)) + (setq tag-qnames (cons qname tag-qnames)) + (if (or (not heading-start-pos) + (and (eq outline-state 'hide-children) + (setq had-children t))) + (setq transparent-depth (1+ transparent-depth)) + (nxml-display-section last-pos + section-start-pos + heading-start-pos + start-tag-indent + outline-state + had-children + tag-qnames) + (setq had-children t) + (setq tag-qnames (cdr tag-qnames)) + (setq last-pos (point)))) + t))) + had-children)) + +(defconst nxml-highlighted-less-than + (propertize "<" 'face 'nxml-tag-delimiter-face)) + +(defconst nxml-highlighted-greater-than + (propertize ">" 'face 'nxml-tag-delimiter-face)) + +(defconst nxml-highlighted-colon + (propertize ":" 'face 'nxml-element-colon-face)) + +(defconst nxml-highlighted-slash + (propertize "/" 'face 'nxml-tag-slash-face)) + +(defconst nxml-highlighted-ellipsis + (propertize "..." 'face 'nxml-outline-ellipsis-face)) + +(defconst nxml-highlighted-empty-end-tag + (concat nxml-highlighted-ellipsis + nxml-highlighted-less-than + nxml-highlighted-slash + nxml-highlighted-greater-than)) + +(defconst nxml-highlighted-inactive-minus + (propertize "-" 'face 'nxml-outline-indicator-face)) + +(defconst nxml-highlighted-active-minus + (propertize "-" 'face 'nxml-outline-active-indicator-face)) + +(defconst nxml-highlighted-active-plus + (propertize "+" 'face 'nxml-outline-active-indicator-face)) + +(defun nxml-display-section (last-pos + section-start-pos + heading-start-pos + parent-indent + parent-outline-state + had-children + tag-qnames) + (let* ((section-start-pos-bol + (save-excursion + (goto-char section-start-pos) + (skip-chars-backward " \t") + (point))) + (outline-state (nxml-get-outline-state section-start-pos)) + (newline-before-section-start-category + (cond ((and (not had-children) parent-outline-state) + 'nxml-outline-display-ellipsis) + (outline-state 'nxml-outline-display-show) + (t nil)))) + (nxml-outline-set-overlay (and parent-outline-state + 'nxml-outline-display-hide) + last-pos + (1- section-start-pos-bol) + nil + t) + (if outline-state + (let* ((indent (if parent-indent + (+ parent-indent nxml-outline-child-indent) + (save-excursion + (goto-char section-start-pos) + (current-column)))) + start-tag-overlay) + (nxml-outline-set-overlay newline-before-section-start-category + (1- section-start-pos-bol) + section-start-pos-bol + t) + (nxml-outline-set-overlay 'nxml-outline-display-hide + section-start-pos-bol + section-start-pos) + (setq start-tag-overlay + (nxml-outline-set-overlay 'nxml-outline-display-show + section-start-pos + (1+ section-start-pos) + t)) + ;; line motion commands don't work right if start-tag-overlay + ;; covers multiple lines + (nxml-outline-set-overlay 'nxml-outline-display-hide + (1+ section-start-pos) + heading-start-pos) + (goto-char heading-start-pos) + (nxml-end-of-heading) + (nxml-outline-set-overlay 'nxml-outline-display-heading + heading-start-pos + (point)) + (let* ((had-children + (nxml-outline-display-rest outline-state + indent + tag-qnames))) + (overlay-put start-tag-overlay + 'display + (concat + ;; indent + (make-string indent ?\ ) + ;; < + nxml-highlighted-less-than + ;; + or - indicator + (cond ((not had-children) + nxml-highlighted-inactive-minus) + ((eq outline-state 'hide-children) + (overlay-put start-tag-overlay + 'category + 'nxml-outline-display-hiding-tag) + nxml-highlighted-active-plus) + (t + (overlay-put start-tag-overlay + 'category + 'nxml-outline-display-showing-tag) + nxml-highlighted-active-minus)) + ;; qname + (nxml-highlighted-qname (car tag-qnames)) + ;; > + nxml-highlighted-greater-than)))) + ;; outline-state nil + (goto-char heading-start-pos) + (nxml-end-of-heading) + (nxml-outline-set-overlay newline-before-section-start-category + (1- section-start-pos-bol) + (point) + t) + (nxml-outline-display-rest outline-state + (and parent-indent + (+ parent-indent + nxml-outline-child-indent)) + tag-qnames)))) + +(defun nxml-highlighted-qname (qname) + (let ((colon (string-match ":" qname))) + (if colon + (concat (propertize (substring qname 0 colon) + 'face + 'nxml-element-prefix-face) + nxml-highlighted-colon + (propertize (substring qname (1+ colon)) + 'face + 'nxml-element-local-name-face)) + (propertize qname + 'face + 'nxml-element-local-name-face)))) + +(defun nxml-outline-display-single-line-end-tag (last-pos) + (nxml-outline-set-overlay 'nxml-outline-display-hide + last-pos + xmltok-start + nil + t) + (overlay-put (nxml-outline-set-overlay 'nxml-outline-display-show + xmltok-start + (point) + t) + 'display + nxml-highlighted-empty-end-tag)) + +(defun nxml-outline-display-multi-line-end-tag (last-pos start-tag-indent) + (let ((indentp (save-excursion + (goto-char last-pos) + (skip-chars-forward " \t") + (and (eq (char-after) ?\n) + (progn + (goto-char (1+ (point))) + (nxml-outline-set-overlay nil last-pos (point)) + (setq last-pos (point)) + (goto-char xmltok-start) + (beginning-of-line) + t)))) + end-tag-overlay) + (nxml-outline-set-overlay 'nxml-outline-display-hide + last-pos + xmltok-start + nil + t) + (setq end-tag-overlay + (nxml-outline-set-overlay 'nxml-outline-display-showing-tag + xmltok-start + (point) + t)) + (overlay-put end-tag-overlay + 'display + (concat (if indentp + (make-string start-tag-indent ?\ ) + "") + nxml-highlighted-less-than + nxml-highlighted-slash + nxml-highlighted-active-minus + (nxml-highlighted-qname (xmltok-end-tag-qname)) + nxml-highlighted-greater-than)))) + +(defvar nxml-outline-show-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'nxml-show-direct-text-content) + (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content) + map)) + +(defvar nxml-outline-show-help "mouse-2: show") + +(put 'nxml-outline-display-show 'nxml-outline-display t) +(put 'nxml-outline-display-show 'evaporate t) +(put 'nxml-outline-display-show 'keymap nxml-outline-show-map) +(put 'nxml-outline-display-show 'help-echo nxml-outline-show-help) + +(put 'nxml-outline-display-hide 'nxml-outline-display t) +(put 'nxml-outline-display-hide 'evaporate t) +(put 'nxml-outline-display-hide 'invisible t) +(put 'nxml-outline-display-hide 'keymap nxml-outline-show-map) +(put 'nxml-outline-display-hide 'help-echo nxml-outline-show-help) + +(put 'nxml-outline-display-ellipsis 'nxml-outline-display t) +(put 'nxml-outline-display-ellipsis 'evaporate t) +(put 'nxml-outline-display-ellipsis 'keymap nxml-outline-show-map) +(put 'nxml-outline-display-ellipsis 'help-echo nxml-outline-show-help) +(put 'nxml-outline-display-ellipsis 'before-string nxml-highlighted-ellipsis) + +(put 'nxml-outline-display-heading 'keymap nxml-outline-show-map) +(put 'nxml-outline-display-heading 'help-echo nxml-outline-show-help) +(put 'nxml-outline-display-heading 'nxml-outline-display t) +(put 'nxml-outline-display-heading 'evaporate t) +(put 'nxml-outline-display-heading 'face 'nxml-heading-face) + +(defvar nxml-outline-hiding-tag-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'nxml-mouse-show-direct-subheadings) + (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content) + (define-key map "\C-m" 'nxml-show-direct-text-content) + map)) + +(defvar nxml-outline-hiding-tag-help + "mouse-1: show subheadings, mouse-2: show text content") + +(put 'nxml-outline-display-hiding-tag 'nxml-outline-display t) +(put 'nxml-outline-display-hiding-tag 'evaporate t) +(put 'nxml-outline-display-hiding-tag 'keymap nxml-outline-hiding-tag-map) +(put 'nxml-outline-display-hiding-tag 'help-echo nxml-outline-hiding-tag-help) + +(defvar nxml-outline-showing-tag-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'nxml-mouse-hide-subheadings) + (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content) + (define-key map "\C-m" 'nxml-show-direct-text-content) + map)) + +(defvar nxml-outline-showing-tag-help + "mouse-1: hide subheadings, mouse-2: show text content") + +(put 'nxml-outline-display-showing-tag 'nxml-outline-display t) +(put 'nxml-outline-display-showing-tag 'evaporate t) +(put 'nxml-outline-display-showing-tag 'keymap nxml-outline-showing-tag-map) +(put 'nxml-outline-display-showing-tag + 'help-echo + nxml-outline-showing-tag-help) + +(defun nxml-outline-set-overlay (category + start + end + &optional + front-advance + rear-advance) + "Replace any nxml-outline-display overlays between START and END. +Overlays are removed if they overlay the region between START and END, +and have a non-nil nxml-outline-display property (typically via their +category). If CATEGORY is non-nil, they will be replaced with a new overlay +with that category from START to END. If CATEGORY is nil, no new +overlay will be created." + (when (< start end) + (let ((overlays (overlays-in start end)) + overlay) + (while overlays + (setq overlay (car overlays)) + (setq overlays (cdr overlays)) + (when (overlay-get overlay 'nxml-outline-display) + (delete-overlay overlay)))) + (and category + (let ((overlay (make-overlay start + end + nil + front-advance + rear-advance))) + (overlay-put overlay 'category category) + (setq line-move-ignore-invisible t) + overlay)))) + +(defun nxml-end-of-heading () + "Move from the start of the content of the heading to the end. +Do not move past the end of the line." + (let ((pos (condition-case err + (and (nxml-scan-element-forward (point) t) + xmltok-start) + nil))) + (end-of-line) + (skip-chars-backward " \t") + (cond ((not pos) + (setq pos (nxml-token-before)) + (when (eq xmltok-type 'end-tag) + (goto-char pos))) + ((< pos (point)) + (goto-char pos))) + (skip-chars-backward " \t") + (point))) + +;;; Navigating section structure + +(defun nxml-token-starts-line-p () + (save-excursion + (goto-char xmltok-start) + (skip-chars-backward " \t") + (bolp))) + +(defvar nxml-cached-section-tag-regexp nil) +(defvar nxml-cached-section-element-name-regexp nil) + +(defsubst nxml-make-section-tag-regexp () + (if (eq nxml-cached-section-element-name-regexp + nxml-section-element-name-regexp) + nxml-cached-section-tag-regexp + (nxml-make-section-tag-regexp-1))) + +(defun nxml-make-section-tag-regexp-1 () + (setq nxml-cached-section-element-name-regexp nil) + (setq nxml-cached-section-tag-regexp + (concat "</?\\(" + "\\(" xmltok-ncname-regexp ":\\)?" + nxml-section-element-name-regexp + "\\)[ \t\r\n>]")) + (setq nxml-cached-section-element-name-regexp + nxml-section-element-name-regexp) + nxml-cached-section-tag-regexp) + +(defun nxml-section-tag-forward () + "Move forward past the first tag that is a section start- or end-tag. +Return xmltok-type for tag. +If no tag found, return nil and move to the end of the buffer." + (let ((case-fold-search nil) + (tag-regexp (nxml-make-section-tag-regexp)) + match-end) + (when (< (point) nxml-prolog-end) + (goto-char nxml-prolog-end)) + (while (cond ((not (re-search-forward tag-regexp nil 'move)) + (setq xmltok-type nil) + nil) + ((progn + (goto-char (match-beginning 0)) + (setq match-end (match-end 0)) + (nxml-ensure-scan-up-to-date) + (let ((end (nxml-inside-end (point)))) + (when end + (goto-char end) + t)))) + ((progn + (xmltok-forward) + (and (memq xmltok-type '(start-tag + partial-start-tag + end-tag + partial-end-tag)) + ;; just in case wildcard matched non-name chars + (= xmltok-name-end (1- match-end)))) + nil) + (t)))) + xmltok-type) + +(defun nxml-section-tag-backward () + "Move backward to the end of a tag that is a section start- or end-tag. +The position of the end of the tag must be <= point +Point is at the end of the tag. `xmltok-start' is the start." + (let ((case-fold-search nil) + (start (point)) + (tag-regexp (nxml-make-section-tag-regexp)) + match-end) + (if (< (point) nxml-prolog-end) + (progn + (goto-char (point-min)) + nil) + (while (cond ((not (re-search-backward tag-regexp + nxml-prolog-end + 'move)) + (setq xmltok-type nil) + (goto-char (point-min)) + nil) + ((progn + (goto-char (match-beginning 0)) + (setq match-end (match-end 0)) + (nxml-ensure-scan-up-to-date) + (let ((pos (nxml-inside-start (point)))) + (when pos + (goto-char (1- pos)) + t)))) + ((progn + (xmltok-forward) + (and (<= (point) start) + (memq xmltok-type '(start-tag + partial-start-tag + end-tag + partial-end-tag)) + ;; just in case wildcard matched non-name chars + (= xmltok-name-end (1- match-end)))) + nil) + (t (goto-char xmltok-start) + t))) + xmltok-type))) + +(defun nxml-section-start-position () + "Return the position of the start of the section containing point. +Signal an error on failure." + (condition-case err + (save-excursion (if (nxml-back-to-section-start) + (point) + (error "Not in section"))) + (nxml-outline-error + (nxml-report-outline-error "Couldn't determine containing section: %s" + err)))) + +(defun nxml-back-to-section-start (&optional invisible-ok) + "Try to move back to the start of the section containing point. +The start of the section must be <= point. +Only visible sections are included unless INVISIBLE-OK is non-nil. +If found, return t. Otherwise move to point-min and return nil. +If unbalanced section tags are found, signal an `nxml-outline-error'." + (when (or (nxml-after-section-start-tag) + (nxml-section-tag-backward)) + (let (open-tags found) + (while (let (section-start-pos) + (setq section-start-pos xmltok-start) + (if (nxml-token-end-tag-p) + (setq open-tags (cons (xmltok-end-tag-qname) + open-tags)) + (if (not open-tags) + (when (and (nxml-token-starts-line-p) + (or invisible-ok + (not (get-char-property section-start-pos + 'invisible))) + (nxml-heading-start-position)) + (setq found t)) + (let ((qname (xmltok-start-tag-qname))) + (unless (string= (car open-tags) qname) + (nxml-outline-error "mismatched end-tag")) + (setq open-tags (cdr open-tags))))) + (goto-char section-start-pos) + (and (not found) + (nxml-section-tag-backward)))) + found))) + +(defun nxml-after-section-start-tag () + "If the character after point is in a section start-tag, move after it. +Return the token type. Otherwise return nil. +Set up variables like `xmltok-forward'." + (let ((pos (nxml-token-after)) + (case-fold-search nil)) + (when (and (memq xmltok-type '(start-tag partial-start-tag)) + (save-excursion + (goto-char xmltok-start) + (looking-at (nxml-make-section-tag-regexp)))) + (goto-char pos) + xmltok-type))) + +(defun nxml-heading-start-position () + "Return the position of the start of the content of a heading element. +Adjust the position to be after initial leading whitespace. +Return nil if no heading element is found. Requires point to be +immediately after the section's start-tag." + (let ((depth 0) + (heading-regexp (concat "\\`\\(" + nxml-heading-element-name-regexp + "\\)\\'")) + + (section-regexp (concat "\\`\\(" + nxml-section-element-name-regexp + "\\)\\'")) + (start (point)) + found) + (save-excursion + (while (and (xmltok-forward) + (cond ((memq xmltok-type '(end-tag partial-end-tag)) + (and (not (string-match section-regexp + (xmltok-end-tag-local-name))) + (> depth 0) + (setq depth (1- depth)))) + ;; XXX Not sure whether this is a good idea + ;;((eq xmltok-type 'empty-element) + ;; nil) + ((not (memq xmltok-type + '(start-tag partial-start-tag))) + t) + ((string-match section-regexp + (xmltok-start-tag-local-name)) + nil) + ((string-match heading-regexp + (xmltok-start-tag-local-name)) + (skip-chars-forward " \t\r\n") + (setq found (point)) + nil) + (t + (setq depth (1+ depth)) + t)) + (<= (- (point) start) nxml-heading-scan-distance)))) + found)) + +;;; Error handling + +(defun nxml-report-outline-error (msg err) + (error msg (apply 'format (cdr err)))) + +(defun nxml-outline-error (&rest args) + (signal 'nxml-outline-error args)) + +(put 'nxml-outline-error + 'error-conditions + '(error nxml-error nxml-outline-error)) + +(put 'nxml-outline-error + 'error-message + "Cannot create outline of buffer that is not well-formed") + +;;; Debugging + +(defun nxml-debug-overlays () + (interactive) + (let ((overlays (nreverse (overlays-in (point-min) (point-max)))) + overlay) + (while overlays + (setq overlay (car overlays)) + (setq overlays (cdr overlays)) + (when (overlay-get overlay 'nxml-outline-display) + (message "overlay %s: %s...%s (%s)" + (overlay-get overlay 'category) + (overlay-start overlay) + (overlay-end overlay) + (overlay-get overlay 'display)))))) + +(provide 'nxml-outln) + +;; arch-tag: 1f1b7454-e573-4cd7-a505-d9dc64eef828 +;;; nxml-outln.el ends here diff --git a/lisp/nxml/nxml-parse.el b/lisp/nxml/nxml-parse.el new file mode 100644 index 00000000000..267c18cf887 --- /dev/null +++ b/lisp/nxml/nxml-parse.el @@ -0,0 +1,323 @@ +;;; nxml-parse.el --- XML parser, sharing infrastructure with nxml-mode + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Entry point is `nxml-parse-file'. + +;;; Code: + +(require 'nxml-util) +(require 'xmltok) +(require 'nxml-enc) +(require 'nxml-ns) + +(defvar nxml-parse-file-name nil) + +(defvar nxml-validate-function nil + "Nil or a function to be called by `nxml-parse-file' to perform validation. +The function will be called once for each start-tag or end-tag. The +function is passed two arguments TEXT and START-TAG. For a start-tag, +START-TAG is a list (NAME ATTRIBUTES) where NAME and ATTRIBUTES are in +the same form as returned by `nxml-parse-file. For an end-tag, +START-TAG is nil. TEXT is a string containing the text immediately +preceding the tag, or nil if there was no such text. An empty element +is treated as a start-tag followed by an end-tag. + +For a start-tag, the namespace state will be the state after +processing the namespace declarations in the start-tag. For an +end-tag, the namespace state will be the state before popping the +namespace declarations for the corresponding start-tag. + +The function must return nil if no error is detected or a +cons (MESSAGE . LOCATION) where MESSAGE is a string containing +an error message and LOCATION indicates what caused the error +as follows: + +- nil indicates the tag as whole caused it; this is always allowed; + +- text indicates the text caused it; this is allowed only if +TEXT is non-nil; + +- tag-close indicates the close of the tag caused it; this is +allowed only if START-TAG is non-nil; + +- (attribute-name . N) indicates that the name of the Nth attribute +caused it; N counts from 0; this is allowed only if START-TAG is non-nil +and N must be less than the number of attributes; + +- (attribute-value . N) indicates that the value of the Nth attribute +caused it; N counts from 0; this is allowed only if START-TAG is non-nil +and N must be less than the number of attributes.") + +(defun nxml-parse-file (file) + "Parse the XML document in FILE and return it as a list. +An XML element is represented as a list (NAME ATTRIBUTES . CHILDREN). +NAME is either a string, in the case where the name does not have a +namespace, or a cons (NAMESPACE . LOCAL-NAME), where NAMESPACE is a +symbol and LOCAL-NAME is a string, in the case where the name does +have a namespace. NAMESPACE is a keyword whose name is `:URI', where +URI is the namespace name. ATTRIBUTES is an alist of attributes where +each attribute has the form (NAME . VALUE), where NAME has the same +form as an element name, and VALUE is a string. A namespace +declaration is represented as an attribute whose name is +\(:http://www.w3.org/2000/xmlns/ . LOCAL-NAME). CHILDREN is a list +containing strings and child elements; CHILDREN never contains two +consecutive strings and never contains an empty string. Processing +instructions and comments are not represented. The return value is a +list representing the document element. + +If the XML document is not well-formed, an error having the condition +`nxml-file-parse-error' will be signaled; the error data will be a +list of the \(FILE POSITION MESSAGE), where POSITION is an integer +specifying the position where the error was detected, and MESSAGE is a +string describing the error. + +The current contents of FILE will be parsed even if there is a +modified buffer currently visiting FILE. + +If the variable `nxml-validation-function' is non-nil, it will be +called twice for each element, and any reported error will be signaled +in the same way as well-formedness error." + (save-excursion + (set-buffer (nxml-parse-find-file file)) + (unwind-protect + (let ((nxml-parse-file-name file)) + (nxml-parse-instance)) + (kill-buffer nil)))) + +(defun nxml-parse-find-file (file) + (save-excursion + (set-buffer (get-buffer-create " *nXML Parse*")) + (erase-buffer) + (let ((set-auto-coding-function 'nxml-set-xml-coding)) + (insert-file-contents file)) + (current-buffer))) + +(defun nxml-parse-instance () + (let (xmltok-dtd) + (xmltok-save + (xmltok-forward-prolog) + (nxml-check-xmltok-errors) + (nxml-ns-save + (nxml-parse-instance-1))))) + +(defun nxml-parse-instance-1 () + (let* ((top (cons nil nil)) + ;; tail is a cons cell, whose cdr is nil + ;; additional elements will destructively appended to tail + (tail top) + ;; stack of tails one for each open element + tail-stack + ;; list of QNames of open elements + open-element-tags + ;; list of strings buffering a text node, in reverse order + text + ;; position of beginning of first (in buffer) string in text + text-pos) + (while (xmltok-forward) + (nxml-check-xmltok-errors) + (cond ((memq xmltok-type '(start-tag end-tag empty-element)) + (when text + (setq text (apply 'concat (nreverse text))) + (setcdr tail (cons text nil)) + (setq tail (cdr tail))) + (when (not (eq xmltok-type 'end-tag)) + (when (and (not open-element-tags) + (not (eq tail top))) + (nxml-parse-error nil "Multiple top-level elements")) + (setq open-element-tags + (cons (xmltok-start-tag-qname) + open-element-tags)) + (nxml-ns-push-state) + (let ((tag (nxml-parse-start-tag))) + (nxml-validate-tag text text-pos tag) + (setq text nil) + (setcdr tail (cons tag nil)) + (setq tail (cdr tail)) + (setq tail-stack (cons tail tail-stack)) + (setq tail (last tag)))) + (when (not (eq xmltok-type 'start-tag)) + (or (eq xmltok-type 'empty-element) + (equal (car open-element-tags) + (xmltok-end-tag-qname)) + (if open-element-tags + (nxml-parse-error nil + "Unbalanced end-tag; expected </%s>" + (car open-element-tags)) + (nxml-parse-error nil "Extra end-tag"))) + (nxml-validate-tag text text-pos nil) + (setq text nil) + (nxml-ns-pop-state) + (setq open-element-tags (cdr open-element-tags)) + (setq tail (car tail-stack)) + (setq tail-stack (cdr tail-stack))) + (setq text-pos nil)) + ((memq xmltok-type '(space data entity-ref char-ref cdata-section)) + (cond (open-element-tags + (unless text-pos + (setq text-pos xmltok-start)) + (setq text + (cons (nxml-current-text-string) text))) + ((not (eq xmltok-type 'space)) + (nxml-parse-error + nil + "%s at top-level" + (cdr (assq xmltok-type + '((data . "Text characters") + (entity-ref . "Entity reference") + (char-ref . "Character reference") + (cdata-section . "CDATA section")))))))))) + (unless (cdr top) + (nxml-parse-error (point-max) "Missing document element")) + (cadr top))) + +(defun nxml-parse-start-tag () + (let (parsed-attributes + parsed-namespace-attributes + atts att prefixes prefix ns value name) + (setq atts xmltok-namespace-attributes) + (while atts + (setq att (car atts)) + (setq value (or (xmltok-attribute-value att) + (nxml-parse-error nil "Invalid attribute value"))) + (setq ns (nxml-make-namespace value)) + (setq prefix (and (xmltok-attribute-prefix att) + (xmltok-attribute-local-name att))) + (cond ((member prefix prefixes) + (nxml-parse-error nil "Duplicate namespace declaration")) + ((not prefix) + (nxml-ns-set-default ns)) + (ns + (nxml-ns-set-prefix prefix ns)) + (t (nxml-parse-error nil "Cannot undeclare namespace prefix"))) + (setq prefixes (cons prefix prefixes)) + (setq parsed-namespace-attributes + (cons (cons (nxml-make-name nxml-xmlns-namespace-uri + (xmltok-attribute-local-name att)) + value) + parsed-namespace-attributes)) + (setq atts (cdr atts))) + (setq name + (nxml-make-name + (let ((prefix (xmltok-start-tag-prefix))) + (if prefix + (or (nxml-ns-get-prefix prefix) + (nxml-parse-error (1+ xmltok-start) + "Prefix `%s' undeclared" + prefix)) + (nxml-ns-get-default))) + (xmltok-start-tag-local-name))) + (setq atts xmltok-attributes) + (while atts + (setq att (car atts)) + (setq ns + (let ((prefix (xmltok-attribute-prefix att))) + (and prefix + (or (nxml-ns-get-prefix prefix) + (nxml-parse-error (xmltok-attribute-name-start att) + "Prefix `%s' undeclared" + prefix))))) + (setq parsed-attributes + (let ((nm (nxml-make-name ns + (xmltok-attribute-local-name att)))) + (when (assoc nm parsed-attributes) + (nxml-parse-error (xmltok-attribute-name-start att) + "Duplicate attribute")) + (cons (cons nm (or (xmltok-attribute-value att) + (nxml-parse-error nil "Invalid attribute value"))) + parsed-attributes))) + (setq atts (cdr atts))) + ;; We want to end up with the attributes followed by the + ;; the namespace attributes in the same order as + ;; xmltok-attributes and xmltok-namespace-attributes respectively. + (when parsed-namespace-attributes + (setq parsed-attributes + (nconc parsed-namespace-attributes parsed-attributes))) + (list name (nreverse parsed-attributes)))) + +(defun nxml-validate-tag (text text-pos tag) + (when nxml-validate-function + (let ((err (funcall nxml-validate-function text tag)) + pos) + (when err + (setq pos (nxml-validate-error-position (cdr err) + (and text text-pos) + tag)) + (or pos (error "Incorrect return value from %s" + nxml-validate-function)) + (nxml-parse-error pos (car err)))))) + +(defun nxml-validate-error-position (location text-pos tag) + (cond ((null location) xmltok-start) + ((eq location 'text) text-pos) + ((eq location 'tag-close) + (and tag (- (point) (if (eq xmltok-type 'empty-element ) 2 1)))) + ((consp location) + (let ((att (nth (cdr location) xmltok-attributes))) + (when (not att) + (setq att (nth (- (cdr location) (length xmltok-attributes)) + xmltok-namespace-attributes))) + (cond ((not att)) + ((eq (car location) 'attribute-name) + (xmltok-attribute-name-start att)) + ((eq (car location) 'attribute-value) + (xmltok-attribute-value-start att))))))) + +(defun nxml-make-name (ns local-name) + (if ns + (cons ns local-name) + local-name)) + +(defun nxml-current-text-string () + (cond ((memq xmltok-type '(space data)) + (buffer-substring-no-properties xmltok-start + (point))) + ((eq xmltok-type 'cdata-section) + (buffer-substring-no-properties (+ xmltok-start 9) + (- (point) 3))) + ((memq xmltok-type '(char-ref entity-ref)) + (unless xmltok-replacement + (nxml-parse-error nil + (if (eq xmltok-type 'char-ref) + "Reference to unsupported Unicode character" + "Unresolvable entity reference"))) + xmltok-replacement))) + +(defun nxml-parse-error (position &rest args) + (nxml-signal-file-parse-error nxml-parse-file-name + (or position xmltok-start) + (apply 'format args))) + +(defun nxml-check-xmltok-errors () + (when xmltok-errors + (let ((err (car (last xmltok-errors)))) + (nxml-signal-file-parse-error nxml-parse-file-name + (xmltok-error-start err) + (xmltok-error-message err))))) + +(provide 'nxml-parse) + +;; arch-tag: fc19639b-1bff-4673-9992-f539da89ba1e +;;; nxml-parse.el ends here diff --git a/lisp/nxml/nxml-rap.el b/lisp/nxml/nxml-rap.el new file mode 100644 index 00000000000..907812be4cb --- /dev/null +++ b/lisp/nxml/nxml-rap.el @@ -0,0 +1,473 @@ +;;; nxml-rap.el --- low-level support for random access parsing for nXML mode + +;; Copyright (C) 2003, 2004, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This uses xmltok.el to do XML parsing. The fundamental problem is +;; how to handle changes. We don't want to maintain a complete parse +;; tree. We also don't want to reparse from the start of the document +;; on every keystroke. However, it is not possible in general to +;; parse an XML document correctly starting at a random point in the +;; middle. The main problems are comments, CDATA sections and +;; processing instructions: these can all contain things that are +;; indistinguishable from elements. Literals in the prolog are also a +;; problem. Attribute value literals are not a problem because +;; attribute value literals cannot contain less-than signs. +;; +;; Our strategy is to keep track of just the problematic things. +;; Specifically, we keep track of all comments, CDATA sections and +;; processing instructions in the instance. We do this by marking all +;; except the first character of these with a non-nil nxml-inside text +;; property. The value of the nxml-inside property is comment, +;; cdata-section or processing-instruction. The first character does +;; not have the nxml-inside property so we can find the beginning of +;; the construct by looking for a change in a text property value +;; (Emacs provides primitives for this). We use text properties +;; rather than overlays, since the implementation of overlays doesn't +;; look like it scales to large numbers of overlays in a buffer. +;; +;; We don't in fact track all these constructs, but only track them in +;; some initial part of the instance. The variable `nxml-scan-end' +;; contains the limit of where we have scanned up to for them. +;; +;; Thus to parse some random point in the file we first ensure that we +;; have scanned up to that point. Then we search backwards for a +;; <. Then we check whether the < has an nxml-inside property. If it +;; does we go backwards to first character that does not have an +;; nxml-inside property (this character must be a <). Then we start +;; parsing forward from the < we have found. +;; +;; The prolog has to be parsed specially, so we also keep track of the +;; end of the prolog in `nxml-prolog-end'. The prolog is reparsed on +;; every change to the prolog. This won't work well if people try to +;; edit huge internal subsets. Hopefully that will be rare. +;; +;; We keep track of the changes by adding to the buffer's +;; after-change-functions hook. Scanning is also done as a +;; prerequisite to fontification by adding to fontification-functions +;; (in the same way as jit-lock). This means that scanning for these +;; constructs had better be quick. Fortunately it is. Firstly, the +;; typical proportion of comments, CDATA sections and processing +;; instructions is small relative to other things. Secondly, to scan +;; we just search for the regexp <[!?]. +;; +;; One problem is unclosed comments, processing instructions and CDATA +;; sections. Suppose, for example, we encounter a <!-- but there's no +;; matching -->. This is not an unexpected situation if the user is +;; creating a comment. It is not helpful to treat the whole of the +;; file starting from the <!-- onwards as a single unclosed comment +;; token. Instead we treat just the <!-- as a piece of not well-formed +;; markup and continue. The problem is that if at some later stage a +;; --> gets added to the buffer after the unclosed <!--, we will need +;; to reparse the buffer starting from the <!--. We need to keep +;; track of these reparse dependencies; they are called dependent +;; regions in the code. + +;;; Code: + +(require 'xmltok) +(require 'nxml-util) + +(defvar nxml-prolog-end nil + "Integer giving position following end of the prolog.") +(make-variable-buffer-local 'nxml-prolog-end) + +(defvar nxml-scan-end nil + "Marker giving position up to which we have scanned. +nxml-scan-end must be >= nxml-prolog-end. Furthermore, nxml-scan-end +must not an inside position in the following sense. A position is +inside if the following character is a part of, but not the first +character of, a CDATA section, comment or processing instruction. +Furthermore all positions >= nxml-prolog-end and < nxml-scan-end that +are inside positions must have a non-nil nxml-inside property whose +value is a symbol specifying what it is inside. Any characters with a +non-nil fontified property must have position < nxml-scan-end and the +correct face. Dependent regions must also be established for any +unclosed constructs starting before nxml-scan-end. +There must be no nxml-inside properties after nxml-scan-end.") +(make-variable-buffer-local 'nxml-scan-end) + +(defsubst nxml-get-inside (pos) + (get-text-property pos 'nxml-inside)) + +(defsubst nxml-clear-inside (start end) + (remove-text-properties start end '(nxml-inside nil))) + +(defsubst nxml-set-inside (start end type) + (put-text-property start end 'nxml-inside type)) + +(defun nxml-inside-end (pos) + "Return the end of the inside region containing POS. +Return nil if the character at POS is not inside." + (if (nxml-get-inside pos) + (or (next-single-property-change pos 'nxml-inside) + (point-max)) + nil)) + +(defun nxml-inside-start (pos) + "Return the start of the inside region containing POS. +Return nil if the character at POS is not inside." + (if (nxml-get-inside pos) + (or (previous-single-property-change (1+ pos) 'nxml-inside) + (point-min)) + nil)) + +;;; Change management + +(defun nxml-scan-after-change (start end) + "Restore `nxml-scan-end' invariants after a change. +The change happened between START and END. +Return position after which lexical state is unchanged. +END must be > nxml-prolog-end." + (if (>= start nxml-scan-end) + nxml-scan-end + (goto-char start) + (nxml-move-outside-backwards) + (setq start (point)) + (let ((inside-remove-start start) + xmltok-errors + xmltok-dependent-regions) + (while (or (when (xmltok-forward-special (min end nxml-scan-end)) + (when (memq xmltok-type + '(comment + cdata-section + processing-instruction)) + (nxml-clear-inside inside-remove-start + (1+ xmltok-start)) + (nxml-set-inside (1+ xmltok-start) + (point) + xmltok-type) + (setq inside-remove-start (point))) + (if (< (point) (min end nxml-scan-end)) + t + (setq end (point)) + nil)) + ;; The end of the change was inside but is now outside. + ;; Imagine something really weird like + ;; <![CDATA[foo <!-- bar ]]> <![CDATA[ stuff --> <!-- ]]> --> + ;; and suppose we deleted "<![CDATA[f" + (let ((inside-end (nxml-inside-end end))) + (when inside-end + (setq end inside-end) + t)))) + (nxml-clear-inside inside-remove-start end) + (nxml-clear-dependent-regions start end) + (nxml-mark-parse-dependent-regions)) + (when (> end nxml-scan-end) + (set-marker nxml-scan-end end)) + end)) + +;; n-s-p only called from nxml-mode.el, where this variable is defined. +(defvar nxml-prolog-regions) + +(defun nxml-scan-prolog () + (goto-char (point-min)) + (let (xmltok-dtd + xmltok-errors + xmltok-dependent-regions) + (setq nxml-prolog-regions (xmltok-forward-prolog)) + (setq nxml-prolog-end (point)) + (nxml-clear-inside (point-min) nxml-prolog-end) + (nxml-clear-dependent-regions (point-min) nxml-prolog-end) + (nxml-mark-parse-dependent-regions)) + (when (< nxml-scan-end nxml-prolog-end) + (set-marker nxml-scan-end nxml-prolog-end))) + + +;;; Dependent regions + +(defun nxml-adjust-start-for-dependent-regions (start end pre-change-length) + (let ((overlays (overlays-in (1- start) start)) + (adjusted-start start)) + (while overlays + (let* ((overlay (car overlays)) + (ostart (overlay-start overlay))) + (when (and (eq (overlay-get overlay 'category) 'nxml-dependent) + (< ostart adjusted-start)) + (let ((funargs (overlay-get overlay 'nxml-funargs))) + (when (apply (car funargs) + (append (list start + end + pre-change-length + ostart + (overlay-end overlay)) + (cdr funargs))) + (setq adjusted-start ostart))))) + (setq overlays (cdr overlays))) + adjusted-start)) + +(defun nxml-mark-parse-dependent-regions () + (while xmltok-dependent-regions + (apply 'nxml-mark-parse-dependent-region + (car xmltok-dependent-regions)) + (setq xmltok-dependent-regions + (cdr xmltok-dependent-regions)))) + +(defun nxml-mark-parse-dependent-region (fun start end &rest args) + (let ((overlay (make-overlay start end nil t t))) + (overlay-put overlay 'category 'nxml-dependent) + (overlay-put overlay 'nxml-funargs (cons fun args)))) + +(put 'nxml-dependent 'evaporate t) + +(defun nxml-clear-dependent-regions (start end) + (let ((overlays (overlays-in start end))) + (while overlays + (let* ((overlay (car overlays)) + (category (overlay-get overlay 'category))) + (when (and (eq category 'nxml-dependent) + (<= start (overlay-start overlay))) + (delete-overlay overlay))) + (setq overlays (cdr overlays))))) + +;;; Random access parsing + +(defun nxml-token-after () + "Return the position after the token containing the char after point. +Sets up the variables `xmltok-type', `xmltok-start', +`xmltok-name-end', `xmltok-name-colon', `xmltok-attributes', +`xmltok-namespace-attributes' in the same was as does +`xmltok-forward'. The prolog will be treated as a single token with +type `prolog'." + (let ((pos (point))) + (if (< pos nxml-prolog-end) + (progn + (setq xmltok-type 'prolog + xmltok-start (point-min)) + (min nxml-prolog-end (point-max))) + (nxml-ensure-scan-up-to-date) + (if (nxml-get-inside pos) + (save-excursion + (nxml-move-outside-backwards) + (xmltok-forward) + (point)) + (save-excursion + (if (or (eq (char-after) ?<) + (search-backward "<" + (max (point-min) nxml-prolog-end) + t)) + (nxml-move-outside-backwards) + (goto-char (if (<= (point-min) nxml-prolog-end) + nxml-prolog-end + (or (nxml-inside-end (point-min)) + (point-min))))) + (while (and (nxml-tokenize-forward) + (<= (point) pos))) + (point)))))) + +(defun nxml-token-before () + "Return the position after the token containing the char before point. +Sets variables like `nxml-token-after'." + (if (/= (point-min) (point)) + (save-excursion + (goto-char (1- (point))) + (nxml-token-after)) + (setq xmltok-start (point)) + (setq xmltok-type nil) + (point))) + +(defun nxml-tokenize-forward () + (let (xmltok-dependent-regions + xmltok-errors) + (when (and (xmltok-forward) + (> (point) nxml-scan-end)) + (cond ((memq xmltok-type '(comment + cdata-section + processing-instruction)) + (nxml-with-unmodifying-text-property-changes + (nxml-set-inside (1+ xmltok-start) (point) xmltok-type))) + (xmltok-dependent-regions + (nxml-mark-parse-dependent-regions))) + (set-marker nxml-scan-end (point))) + xmltok-type)) + +(defun nxml-move-outside-backwards () + "Move point to first character of the containing special thing. +Leave point unmoved if it is not inside anything special." + (let ((start (nxml-inside-start (point)))) + (when start + (goto-char (1- start)) + (when (nxml-get-inside (point)) + (error "Char before inside-start at %s had nxml-inside property %s" + (point) + (nxml-get-inside (point))))))) + +(defun nxml-ensure-scan-up-to-date () + (let ((pos (point))) + (when (< nxml-scan-end pos) + (save-excursion + (goto-char nxml-scan-end) + (let (xmltok-errors + xmltok-dependent-regions) + (while (when (xmltok-forward-special pos) + (when (memq xmltok-type + '(comment + processing-instruction + cdata-section)) + (nxml-with-unmodifying-text-property-changes + (nxml-set-inside (1+ xmltok-start) + (point) + xmltok-type))) + (if (< (point) pos) + t + (setq pos (point)) + nil))) + (nxml-clear-dependent-regions nxml-scan-end pos) + (nxml-mark-parse-dependent-regions) + (set-marker nxml-scan-end pos)))))) + +;;; Element scanning + +(defun nxml-scan-element-forward (from &optional up) + "Scan forward from FROM over a single balanced element. +Point must between tokens. Return the position of the end of the tag +that ends the element. `xmltok-start' will contain the position of the +start of the tag. If UP is non-nil, then scan past end-tag of element +containing point. If no element is found, return nil. If a +well-formedness error prevents scanning, signal an nxml-scan-error. +Point is not moved." + (let ((open-tags (and up t)) + found) + (save-excursion + (goto-char from) + (while (cond ((not (nxml-tokenize-forward)) + (when (consp open-tags) + (nxml-scan-error (cadr open-tags) + "Start-tag has no end-tag")) + nil) + ((eq xmltok-type 'start-tag) + (setq open-tags + (cons (xmltok-start-tag-qname) + (cons xmltok-start + open-tags))) + t) + ((eq xmltok-type 'end-tag) + (cond ((not open-tags) nil) + ((not (consp open-tags)) (setq found (point)) nil) + ((not (string= (car open-tags) + (xmltok-end-tag-qname))) + (nxml-scan-error (+ 2 xmltok-start) + "Mismatched end-tag; \ +expected `%s'" + (car open-tags))) + ((setq open-tags (cddr open-tags)) t) + (t (setq found (point)) nil))) + ((memq xmltok-type '(empty-element + partial-empty-element)) + (if open-tags + t + (setq found (point)) + nil)) + ((eq xmltok-type 'partial-end-tag) + (cond ((not open-tags) nil) + ((not (consp open-tags)) (setq found (point)) nil) + ((setq open-tags (cddr open-tags)) t) + (t (setq found (point)) nil))) + ((eq xmltok-type 'partial-start-tag) + (nxml-scan-error xmltok-start + "Missing `>'")) + (t t)))) + found)) + +(defun nxml-scan-element-backward (from &optional up bound) + "Scan backward from FROM over a single balanced element. +Point must between tokens. Return the position of the end of the tag +that starts the element. `xmltok-start' will contain the position of +the start of the tag. If UP is non-nil, then scan past start-tag of +element containing point. If BOUND is non-nil, then don't scan back +past BOUND. If no element is found, return nil. If a well-formedness +error prevents scanning, signal an nxml-scan-error. Point is not +moved." + (let ((open-tags (and up t)) + token-end found) + (save-excursion + (goto-char from) + (while (cond ((or (< (point) nxml-prolog-end) + (not (search-backward "<" + (max (or bound 0) + nxml-prolog-end) + t))) + (when (and (consp open-tags) (not bound)) + (nxml-scan-error (cadr open-tags) + "End-tag has no start-tag")) + nil) + ((progn + (nxml-move-outside-backwards) + (save-excursion + (nxml-tokenize-forward) + (setq token-end (point))) + (eq xmltok-type 'end-tag)) + (setq open-tags + (cons (xmltok-end-tag-qname) + (cons xmltok-start open-tags))) + t) + ((eq xmltok-type 'start-tag) + (cond ((not open-tags) nil) + ((not (consp open-tags)) + (setq found token-end) + nil) + ((and (car open-tags) + (not (string= (car open-tags) + (xmltok-start-tag-qname)))) + (nxml-scan-error (1+ xmltok-start) + "Mismatched start-tag; \ +expected `%s'" + (car open-tags))) + ((setq open-tags (cddr open-tags)) t) + (t (setq found token-end) nil))) + ((memq xmltok-type '(empty-element + partial-empty-element)) + (if open-tags + t + (setq found token-end) + nil)) + ((eq xmltok-type 'partial-end-tag) + (setq open-tags + (cons nil (cons xmltok-start open-tags))) + t) + ((eq xmltok-type 'partial-start-tag) + ;; if we have only a partial-start-tag + ;; then it's unlikely that there's a matching + ;; end-tag, so it's probably not helpful + ;; to treat it as a complete start-tag + (nxml-scan-error xmltok-start + "Missing `>'")) + (t t)))) + found)) + +(defun nxml-scan-error (&rest args) + (signal 'nxml-scan-error args)) + +(put 'nxml-scan-error + 'error-conditions + '(error nxml-error nxml-scan-error)) + +(put 'nxml-scan-error + 'error-message + "Scan over element that is not well-formed") + +(provide 'nxml-rap) + +;; arch-tag: cba241ec-4c59-4ef3-aa51-2cf92b3dd24f +;;; nxml-rap.el ends here diff --git a/lisp/nxml/nxml-uchnm.el b/lisp/nxml/nxml-uchnm.el new file mode 100644 index 00000000000..9514a7de476 --- /dev/null +++ b/lisp/nxml/nxml-uchnm.el @@ -0,0 +1,259 @@ +;;; nxml-uchnm.el --- support for Unicode standard cha names in nxml-mode + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This enables the use of the character names defined in the Unicode +;; Standard. The use of the names can be controlled on a per-block +;; basis, so as both to reduce memory usage and loading time, +;; and to make completion work better. +;; The main entry point is `nxml-enable-unicode-char-name-sets'. Typically, +;; this is added to `nxml-mode-hook' (rng-auto.el does this already). +;; To customize the blocks for which names are used + +;;; Code: + +(require 'nxml-mode) + +(defconst nxml-unicode-blocks + '(("Basic Latin" #x0000 #x007F) + ("Latin-1 Supplement" #x0080 #x00FF) + ("Latin Extended-A" #x0100 #x017F) + ("Latin Extended-B" #x0180 #x024F) + ("IPA Extensions" #x0250 #x02AF) + ("Spacing Modifier Letters" #x02B0 #x02FF) + ("Combining Diacritical Marks" #x0300 #x036F) + ("Greek and Coptic" #x0370 #x03FF) + ("Cyrillic" #x0400 #x04FF) + ("Cyrillic Supplementary" #x0500 #x052F) + ("Armenian" #x0530 #x058F) + ("Hebrew" #x0590 #x05FF) + ("Arabic" #x0600 #x06FF) + ("Syriac" #x0700 #x074F) + ("Thaana" #x0780 #x07BF) + ("Devanagari" #x0900 #x097F) + ("Bengali" #x0980 #x09FF) + ("Gurmukhi" #x0A00 #x0A7F) + ("Gujarati" #x0A80 #x0AFF) + ("Oriya" #x0B00 #x0B7F) + ("Tamil" #x0B80 #x0BFF) + ("Telugu" #x0C00 #x0C7F) + ("Kannada" #x0C80 #x0CFF) + ("Malayalam" #x0D00 #x0D7F) + ("Sinhala" #x0D80 #x0DFF) + ("Thai" #x0E00 #x0E7F) + ("Lao" #x0E80 #x0EFF) + ("Tibetan" #x0F00 #x0FFF) + ("Myanmar" #x1000 #x109F) + ("Georgian" #x10A0 #x10FF) + ("Hangul Jamo" #x1100 #x11FF) + ("Ethiopic" #x1200 #x137F) + ("Cherokee" #x13A0 #x13FF) + ("Unified Canadian Aboriginal Syllabics" #x1400 #x167F) + ("Ogham" #x1680 #x169F) + ("Runic" #x16A0 #x16FF) + ("Tagalog" #x1700 #x171F) + ("Hanunoo" #x1720 #x173F) + ("Buhid" #x1740 #x175F) + ("Tagbanwa" #x1760 #x177F) + ("Khmer" #x1780 #x17FF) + ("Mongolian" #x1800 #x18AF) + ("Latin Extended Additional" #x1E00 #x1EFF) + ("Greek Extended" #x1F00 #x1FFF) + ("General Punctuation" #x2000 #x206F) + ("Superscripts and Subscripts" #x2070 #x209F) + ("Currency Symbols" #x20A0 #x20CF) + ("Combining Diacritical Marks for Symbols" #x20D0 #x20FF) + ("Letterlike Symbols" #x2100 #x214F) + ("Number Forms" #x2150 #x218F) + ("Arrows" #x2190 #x21FF) + ("Mathematical Operators" #x2200 #x22FF) + ("Miscellaneous Technical" #x2300 #x23FF) + ("Control Pictures" #x2400 #x243F) + ("Optical Character Recognition" #x2440 #x245F) + ("Enclosed Alphanumerics" #x2460 #x24FF) + ("Box Drawing" #x2500 #x257F) + ("Block Elements" #x2580 #x259F) + ("Geometric Shapes" #x25A0 #x25FF) + ("Miscellaneous Symbols" #x2600 #x26FF) + ("Dingbats" #x2700 #x27BF) + ("Miscellaneous Mathematical Symbols-A" #x27C0 #x27EF) + ("Supplemental Arrows-A" #x27F0 #x27FF) + ("Braille Patterns" #x2800 #x28FF) + ("Supplemental Arrows-B" #x2900 #x297F) + ("Miscellaneous Mathematical Symbols-B" #x2980 #x29FF) + ("Supplemental Mathematical Operators" #x2A00 #x2AFF) + ("CJK Radicals Supplement" #x2E80 #x2EFF) + ("Kangxi Radicals" #x2F00 #x2FDF) + ("Ideographic Description Characters" #x2FF0 #x2FFF) + ("CJK Symbols and Punctuation" #x3000 #x303F) + ("Hiragana" #x3040 #x309F) + ("Katakana" #x30A0 #x30FF) + ("Bopomofo" #x3100 #x312F) + ("Hangul Compatibility Jamo" #x3130 #x318F) + ("Kanbun" #x3190 #x319F) + ("Bopomofo Extended" #x31A0 #x31BF) + ("Katakana Phonetic Extensions" #x31F0 #x31FF) + ("Enclosed CJK Letters and Months" #x3200 #x32FF) + ("CJK Compatibility" #x3300 #x33FF) + ("CJK Unified Ideographs Extension A" #x3400 #x4DBF) + ;;("CJK Unified Ideographs" #x4E00 #x9FFF) + ("Yi Syllables" #xA000 #xA48F) + ("Yi Radicals" #xA490 #xA4CF) + ;;("Hangul Syllables" #xAC00 #xD7AF) + ;;("High Surrogates" #xD800 #xDB7F) + ;;("High Private Use Surrogates" #xDB80 #xDBFF) + ;;("Low Surrogates" #xDC00 #xDFFF) + ;;("Private Use Area" #xE000 #xF8FF) + ;;("CJK Compatibility Ideographs" #xF900 #xFAFF) + ("Alphabetic Presentation Forms" #xFB00 #xFB4F) + ("Arabic Presentation Forms-A" #xFB50 #xFDFF) + ("Variation Selectors" #xFE00 #xFE0F) + ("Combining Half Marks" #xFE20 #xFE2F) + ("CJK Compatibility Forms" #xFE30 #xFE4F) + ("Small Form Variants" #xFE50 #xFE6F) + ("Arabic Presentation Forms-B" #xFE70 #xFEFF) + ("Halfwidth and Fullwidth Forms" #xFF00 #xFFEF) + ("Specials" #xFFF0 #xFFFF) + ("Old Italic" #x10300 #x1032F) + ("Gothic" #x10330 #x1034F) + ("Deseret" #x10400 #x1044F) + ("Byzantine Musical Symbols" #x1D000 #x1D0FF) + ("Musical Symbols" #x1D100 #x1D1FF) + ("Mathematical Alphanumeric Symbols" #x1D400 #x1D7FF) + ;;("CJK Unified Ideographs Extension B" #x20000 #x2A6DF) + ;;("CJK Compatibility Ideographs Supplement" #x2F800 #x2FA1F) + ("Tags" #xE0000 #xE007F) + ;;("Supplementary Private Use Area-A" #xF0000 #xFFFFF) + ;;("Supplementary Private Use Area-B" #x100000 #x10FFFF) + ) + "List of Unicode blocks. +For each block there is a list (NAME FIRST LAST), where +NAME is a string giving the offical name of the block, +FIRST is the first code-point and LAST is the last code-point. +Blocks containing only characters with algorithmic names or no names +are omitted.") + +(defun nxml-unicode-block-char-name-set (name) + "Return a symbol for a block whose offical Unicode name is NAME. +The symbol is generated by downcasing and replacing each space +by a hyphen." + (intern (replace-regexp-in-string " " "-" (downcase name)))) + +;; This is intended to be a superset of the coverage +;; of existing standard entity sets. +(defvar nxml-enabled-unicode-blocks-default + '(basic-latin + latin-1-supplement + latin-extended-a + latin-extended-b + ipa-extensions + spacing-modifier-letters + combining-diacritical-marks + greek-and-coptic + cyrillic + general-punctuation + superscripts-and-subscripts + currency-symbols + combining-diacritical-marks-for-symbols + letterlike-symbols + number-forms + arrows + mathematical-operators + miscellaneous-technical + control-pictures + optical-character-recognition + enclosed-alphanumerics + box-drawing + block-elements + geometric-shapes + miscellaneous-symbols + dingbats + miscellaneous-mathematical-symbols-a + supplemental-arrows-a + supplemental-arrows-b + miscellaneous-mathematical-symbols-b + supplemental-mathematical-operators + cjk-symbols-and-punctuation + alphabetic-presentation-forms + variation-selectors + small-form-variants + specials + mathematical-alphanumeric-symbols) + "Default value for `nxml-enabled-unicode-blocks'.") + +(mapc (lambda (block) + (nxml-autoload-char-name-set + (nxml-unicode-block-char-name-set (car block)) + (expand-file-name + (format "nxml/%05X-%05X" + (nth 1 block) + (nth 2 block)) + data-directory))) + nxml-unicode-blocks) + +(defvar nxml-enable-unicode-char-name-sets-flag nil) + +(defcustom nxml-enabled-unicode-blocks nxml-enabled-unicode-blocks-default + "List of Unicode blocks for which Unicode character names are enabled. +Each block is identified by a symbol derived from the name +of the block by downcasing and replacing each space by a hyphen." + :group 'nxml + :set (lambda (sym value) + (set-default 'nxml-enabled-unicode-blocks value) + (when nxml-enable-unicode-char-name-sets-flag + (nxml-enable-unicode-char-name-sets-1))) + :type (cons 'set + (mapcar (lambda (block) + `(const :tag ,(format "%s (%04X-%04X)" + (nth 0 block) + (nth 1 block) + (nth 2 block)) + ,(nxml-unicode-block-char-name-set + (nth 0 block)))) + nxml-unicode-blocks))) + +;;;###autoload +(defun nxml-enable-unicode-char-name-sets () + "Enable the use of Unicode standard names for characters. +The Unicode blocks for which names are enabled is controlled by +the variable `nxml-enabled-unicode-blocks'." + (interactive) + (setq nxml-char-name-ignore-case t) + (setq nxml-enable-unicode-char-name-sets-flag t) + (nxml-enable-unicode-char-name-sets-1)) + +(defun nxml-enable-unicode-char-name-sets-1 () + (mapc (lambda (block) + (nxml-disable-char-name-set + (nxml-unicode-block-char-name-set (car block)))) + nxml-unicode-blocks) + (mapc (lambda (nameset) + (nxml-enable-char-name-set nameset)) + nxml-enabled-unicode-blocks)) + +(provide 'nxml-uchnm) + +;; arch-tag: 440248c3-b604-467c-8b50-e83662c659a3 +;;; nxml-uchnm.el ends here diff --git a/lisp/nxml/nxml-util.el b/lisp/nxml/nxml-util.el new file mode 100644 index 00000000000..73b8354ddf6 --- /dev/null +++ b/lisp/nxml/nxml-util.el @@ -0,0 +1,103 @@ +;;; nxml-util.el --- utility functions for nxml-*.el + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(defun nxml-make-namespace (str) + "Return a symbol for the namespace URI STR. +STR must be a string. If STR is the empty string, return nil. +Otherwise, return the symbol whose name is STR prefixed with a colon." + (if (string-equal str "") + nil + (intern (concat ":" str)))) + +(defun nxml-namespace-name (ns) + "Return the namespace URI corresponding to the symbol NS. +This is the inverse of `nxml-make-namespace'." + (and ns (substring (symbol-name ns) 1))) + +(defconst nxml-xml-namespace-uri + (nxml-make-namespace "http://www.w3.org/XML/1998/namespace")) + +(defconst nxml-xmlns-namespace-uri + (nxml-make-namespace "http://www.w3.org/2000/xmlns/")) + +(defmacro nxml-with-unmodifying-text-property-changes (&rest body) + "Evaluate BODY without any text property changes modifying the buffer. +Any text properties changes happen as usual but the changes are not treated as +modifications to the buffer." + (let ((modified (make-symbol "modified"))) + `(let ((,modified (buffer-modified-p)) + (inhibit-read-only t) + (inhibit-modification-hooks t) + (buffer-undo-list t) + (deactivate-mark nil) + ;; Apparently these avoid file locking problems. + (buffer-file-name nil) + (buffer-file-truename nil)) + (unwind-protect + (progn ,@body) + (unless ,modified + (restore-buffer-modified-p nil)))))) + +(put 'nxml-with-unmodifying-text-property-changes 'lisp-indent-function 0) +(def-edebug-spec nxml-with-unmodifying-text-property-changes t) + +(defmacro nxml-with-invisible-motion (&rest body) + "Evaluate body without calling any point motion hooks." + `(let ((inhibit-point-motion-hooks t)) + ,@body)) + +(put 'nxml-with-invisible-motion 'lisp-indent-function 0) +(def-edebug-spec nxml-with-invisible-motion t) + +(defun nxml-display-file-parse-error (err) + (let* ((filename (nth 1 err)) + (buffer (find-file-noselect filename)) + (pos (nth 2 err)) + (message (nth 3 err))) + (pop-to-buffer buffer) + ;; What's the right thing to do if the buffer's modified? + ;; The position in the saved file could be completely different. + (goto-char (if (buffer-modified-p) 1 pos)) + (error "%s" message))) + +(defun nxml-signal-file-parse-error (file pos message &optional error-symbol) + (signal (or error-symbol 'nxml-file-parse-error) + (list file pos message))) + +(put 'nxml-file-parse-error + 'error-conditions + '(error nxml-file-parse-error)) + +(put 'nxml-parse-file-error + 'error-message + "Error parsing file") + +(provide 'nxml-util) + +;; arch-tag: 7d3b3af4-de2b-4410-bf67-94d64824324b +;;; nxml-util.el ends here diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el new file mode 100644 index 00000000000..a83af6ad077 --- /dev/null +++ b/lisp/nxml/rng-cmpct.el @@ -0,0 +1,941 @@ +;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This parses a RELAX NG Compact Syntax schema into the form +;; specified in rng-pttrn.el. +;; +;; RELAX NG Compact Syntax is specified by +;; http://relaxng.org/compact.html +;; +;; This file uses the prefix "rng-c-". + +;;; Code: + +(require 'nxml-util) +(require 'rng-util) +(require 'rng-uri) +(require 'rng-pttrn) + +;;;###autoload +(defun rng-c-load-schema (filename) + "Load a schema in RELAX NG compact syntax from FILENAME. +Return a pattern." + (rng-c-parse-file filename)) + +;;; Error handling + +(put 'rng-c-incorrect-schema + 'error-conditions + '(error rng-error nxml-file-parse-error rng-c-incorrect-schema)) + +(put 'rng-c-incorrect-schema + 'error-message + "Incorrect schema") + +(defun rng-c-signal-incorrect-schema (filename pos message) + (nxml-signal-file-parse-error filename + pos + message + 'rng-c-incorrect-schema)) + +;;; Lexing + +(defconst rng-c-keywords + '("attribute" + "default" + "datatypes" + "div" + "element" + "empty" + "external" + "grammar" + "include" + "inherit" + "list" + "mixed" + "namespace" + "notAllowed" + "parent" + "start" + "string" + "text" + "token") + "List of strings that are keywords in the compact syntax.") + +(defconst rng-c-anchored-keyword-re + (concat "\\`\\(" (regexp-opt rng-c-keywords) "\\)\\'") + "Regular expression to match a keyword in the compact syntax.") + +(defvar rng-c-syntax-table nil + "Syntax table for parsing the compact syntax.") + +(if rng-c-syntax-table + () + (setq rng-c-syntax-table (make-syntax-table)) + (modify-syntax-entry ?# "<" rng-c-syntax-table) + (modify-syntax-entry ?\n ">" rng-c-syntax-table) + (modify-syntax-entry ?- "w" rng-c-syntax-table) + (modify-syntax-entry ?. "w" rng-c-syntax-table) + (modify-syntax-entry ?_ "w" rng-c-syntax-table) + (modify-syntax-entry ?: "_" rng-c-syntax-table)) + +(defconst rng-c-literal-1-re + "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'" + "Regular expression to match a single-quoted literal.") + +(defconst rng-c-literal-2-re + (replace-regexp-in-string "'" "\"" rng-c-literal-1-re) + "Regular expression to match a double-quoted literal.") + +(defconst rng-c-ncname-re "\\w+") + +(defconst rng-c-anchored-ncname-re + (concat "\\`" rng-c-ncname-re "\\'")) + +(defconst rng-c-token-re + (concat "[&|]=" "\\|" + "[][()|&,*+?{}~=-]" "\\|" + rng-c-literal-1-re "\\|" + rng-c-literal-2-re "\\|" + rng-c-ncname-re "\\(:\\(\\*\\|" rng-c-ncname-re "\\)\\)?" "\\|" + "\\\\" rng-c-ncname-re "\\|" + ">>") + "Regular expression to match a token in the compact syntax.") + +(defun rng-c-init-buffer () + (setq case-fold-search nil) ; automatically becomes buffer-local when set + (set-buffer-multibyte t) + (set-syntax-table rng-c-syntax-table)) + +(defvar rng-c-current-token nil) +(make-variable-buffer-local 'rng-c-current-token) + +(defun rng-c-advance () + (cond ((looking-at rng-c-token-re) + (setq rng-c-current-token (match-string 0)) + (goto-char (match-end 0)) + (forward-comment (point-max))) + ((= (point) (point-max)) + (setq rng-c-current-token "")) + (t (rng-c-error "Invalid token")))) + +(defconst rng-c-anchored-datatype-name-re + (concat "\\`" rng-c-ncname-re ":" rng-c-ncname-re "\\'")) + +(defsubst rng-c-current-token-keyword-p () + (string-match rng-c-anchored-keyword-re rng-c-current-token)) + +(defsubst rng-c-current-token-prefixed-name-p () + (string-match rng-c-anchored-datatype-name-re rng-c-current-token)) + +(defsubst rng-c-current-token-literal-p () + (string-match "\\`['\"]" rng-c-current-token)) + +(defsubst rng-c-current-token-quoted-identifier-p () + (string-match "\\`\\\\" rng-c-current-token)) + +(defsubst rng-c-current-token-ncname-p () + (string-match rng-c-anchored-ncname-re rng-c-current-token)) + +(defsubst rng-c-current-token-ns-name-p () + (let ((len (length rng-c-current-token))) + (and (> len 0) + (= (aref rng-c-current-token (- len 1)) ?*)))) + +;;; Namespaces + +(defvar rng-c-inherit-namespace nil) + +(defvar rng-c-default-namespace nil) + +(defvar rng-c-default-namespace-declared nil) + +(defvar rng-c-namespace-decls nil + "Alist of namespace declarations.") + +(defconst rng-c-no-namespace nil) + +(defun rng-c-declare-standard-namespaces () + (setq rng-c-namespace-decls + (cons (cons "xml" nxml-xml-namespace-uri) + rng-c-namespace-decls)) + (when (and (not rng-c-default-namespace-declared) + rng-c-inherit-namespace) + (setq rng-c-default-namespace rng-c-inherit-namespace))) + +(defun rng-c-expand-name (prefixed-name) + (let ((i (string-match ":" prefixed-name))) + (rng-make-name (rng-c-lookup-prefix (substring prefixed-name + 0 + i)) + (substring prefixed-name (+ i 1))))) + +(defun rng-c-lookup-prefix (prefix) + (let ((binding (assoc prefix rng-c-namespace-decls))) + (or binding (rng-c-error "Undefined prefix %s" prefix)) + (cdr binding))) + +(defun rng-c-unqualified-namespace (attribute) + (if attribute + rng-c-no-namespace + rng-c-default-namespace)) + +(defun rng-c-make-context () + (cons rng-c-default-namespace rng-c-namespace-decls)) + +;;; Datatypes + +(defconst rng-string-datatype + (rng-make-datatype rng-builtin-datatypes-uri "string")) + +(defconst rng-token-datatype + (rng-make-datatype rng-builtin-datatypes-uri "token")) + +(defvar rng-c-datatype-decls nil + "Alist of datatype declarations. +Contains a list of pairs (PREFIX . URI) where PREFIX is a string +and URI is a symbol.") + +(defun rng-c-declare-standard-datatypes () + (setq rng-c-datatype-decls + (cons (cons "xsd" rng-xsd-datatypes-uri) + rng-c-datatype-decls))) + +(defun rng-c-lookup-datatype-prefix (prefix) + (let ((binding (assoc prefix rng-c-datatype-decls))) + (or binding (rng-c-error "Undefined prefix %s" prefix)) + (cdr binding))) + +(defun rng-c-expand-datatype (prefixed-name) + (let ((i (string-match ":" prefixed-name))) + (rng-make-datatype + (rng-c-lookup-datatype-prefix (substring prefixed-name 0 i)) + (substring prefixed-name (+ i 1))))) + +;;; Grammars + +(defvar rng-c-current-grammar nil) +(defvar rng-c-parent-grammar nil) + +(defun rng-c-make-grammar () + (make-hash-table :test 'equal)) + +(defconst rng-c-about-override-slot 0) +(defconst rng-c-about-combine-slot 1) + +(defun rng-c-lookup-create (name grammar) + "Return a def object for NAME. A def object is a pair +\(ABOUT . REF) where REF is returned by `rng-make-ref'. ABOUT is a +two-element vector [OVERRIDE COMBINE]. COMBINE is either nil, choice +or interleave. OVERRIDE is either nil, require or t." + (let ((def (gethash name grammar))) + (if def + def + (progn + (setq def (cons (vector nil nil) (rng-make-ref name))) + (puthash name def grammar) + def)))) + +(defun rng-c-make-ref (name) + (or rng-c-current-grammar + (rng-c-error "Reference not in a grammar")) + (cdr (rng-c-lookup-create name rng-c-current-grammar))) + +(defun rng-c-make-parent-ref (name) + (or rng-c-parent-grammar + (rng-c-error "Reference to non-existent parent grammar")) + (cdr (rng-c-lookup-create name rng-c-parent-grammar))) + +(defvar rng-c-overrides nil + "Contains a list of (NAME . DEF) pairs.") + +(defun rng-c-merge-combine (def combine name) + (let* ((about (car def)) + (current-combine (aref about rng-c-about-combine-slot))) + (if combine + (if current-combine + (or (eq combine current-combine) + (rng-c-error "Inconsistent combine for %s" name)) + (aset about rng-c-about-combine-slot combine)) + current-combine))) + +(defun rng-c-prepare-define (name combine in-include) + (let* ((def (rng-c-lookup-create name rng-c-current-grammar)) + (about (car def)) + (overridden (aref about rng-c-about-override-slot))) + (and in-include + (setq rng-c-overrides (cons (cons name def) rng-c-overrides))) + (cond (overridden (and (eq overridden 'require) + (aset about rng-c-about-override-slot t)) + nil) + (t (setq combine (rng-c-merge-combine def combine name)) + (and (rng-ref-get (cdr def)) + (not combine) + (rng-c-error "Duplicate definition of %s" name)) + def)))) + +(defun rng-c-start-include (overrides) + (mapcar (lambda (name-def) + (let* ((def (cdr name-def)) + (about (car def)) + (save (aref about rng-c-about-override-slot))) + (aset about rng-c-about-override-slot 'require) + (cons save name-def))) + overrides)) + +(defun rng-c-end-include (overrides) + (mapcar (lambda (o) + (let* ((saved (car o)) + (name-def (cdr o)) + (name (car name-def)) + (def (cdr name-def)) + (about (car def))) + (and (eq (aref about rng-c-about-override-slot) 'require) + (rng-c-error "Definition of %s in include did not override definition in included file" name)) + (aset about rng-c-about-override-slot saved))) + overrides)) + +(defun rng-c-define (def value) + (and def + (let ((current-value (rng-ref-get (cdr def)))) + (rng-ref-set (cdr def) + (if current-value + (if (eq (aref (car def) rng-c-about-combine-slot) + 'choice) + (rng-make-choice (list current-value value)) + (rng-make-interleave (list current-value value))) + value))))) + +(defun rng-c-finish-grammar () + (maphash (lambda (key def) + (or (rng-ref-get (cdr def)) + (rng-c-error "Reference to undefined pattern %s" key))) + rng-c-current-grammar) + (rng-ref-get (cdr (or (gethash 'start rng-c-current-grammar) + (rng-c-error "No definition of start"))))) + +;;; Parsing + +(defvar rng-c-escape-positions nil) +(make-variable-buffer-local 'rng-c-escape-positions) + +(defvar rng-c-file-name nil) +(make-variable-buffer-local 'rng-c-file-name) + +(defvar rng-c-file-index nil) + +(defun rng-c-parse-file (filename &optional context) + (save-excursion + (set-buffer (get-buffer-create (rng-c-buffer-name context))) + (erase-buffer) + (rng-c-init-buffer) + (setq rng-c-file-name + (car (insert-file-contents filename))) + (setq rng-c-escape-positions nil) + (rng-c-process-escapes) + (rng-c-parse-top-level context))) + +(defun rng-c-buffer-name (context) + (concat " *RNC Input" + (if context + (concat "<" + (number-to-string (setq rng-c-file-index + (1+ rng-c-file-index))) + ">*") + (setq rng-c-file-index 1) + "*"))) + +(defun rng-c-process-escapes () + ;; Check for any nuls, since we will use nul chars + ;; for internal purposes. + (let ((pos (search-forward "\C-@" nil t))) + (and pos + (rng-c-error "Nul character found (binary file?)"))) + (let ((offset 0)) + (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}" + (point-max) + t) + (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16)))) + (if (and ch (> ch 0)) + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (delete-region begin end) + ;; Represent an escaped newline by nul, so + ;; that we can distinguish it from a literal newline. + ;; We will translate it back into a real newline later. + (insert (if (eq ch ?\n) 0 ch)) + (setq offset (+ offset (- end begin 1))) + (setq rng-c-escape-positions + (cons (cons (point) offset) + rng-c-escape-positions))) + (rng-c-error "Invalid character escape"))))) + (goto-char 1)) + +(defun rng-c-translate-position (pos) + (let ((tem rng-c-escape-positions)) + (while (and tem + (> (caar tem) pos)) + (setq tem (cdr tem))) + (if tem + (+ pos (cdar tem)) + pos))) + +(defun rng-c-error (&rest args) + (rng-c-signal-incorrect-schema rng-c-file-name + (rng-c-translate-position (point)) + (apply 'format args))) + +(defun rng-c-parse-top-level (context) + (let ((rng-c-namespace-decls nil) + (rng-c-default-namespace nil) + (rng-c-datatype-decls nil)) + (goto-char (point-min)) + (forward-comment (point-max)) + (rng-c-advance) + (rng-c-parse-decls) + (let ((p (if (eq context 'include) + (if (rng-c-implicit-grammar-p) + (rng-c-parse-grammar-body "") + (rng-c-parse-included-grammar)) + (if (rng-c-implicit-grammar-p) + (rng-c-parse-implicit-grammar) + (rng-c-parse-pattern))))) + (or (string-equal rng-c-current-token "") + (rng-c-error "Unexpected characters after pattern")) + p))) + +(defun rng-c-parse-included-grammar () + (or (string-equal rng-c-current-token "grammar") + (rng-c-error "Included schema is not a grammar")) + (rng-c-advance) + (rng-c-expect "{") + (rng-c-parse-grammar-body "}")) + +(defun rng-c-implicit-grammar-p () + (or (and (or (rng-c-current-token-prefixed-name-p) + (rng-c-current-token-quoted-identifier-p) + (and (rng-c-current-token-ncname-p) + (not (rng-c-current-token-keyword-p)))) + (looking-at "\\[")) + (and (string-equal rng-c-current-token "[") + (rng-c-parse-lead-annotation) + nil) + (member rng-c-current-token '("div" "include" "")) + (looking-at "[|&]?="))) + +(defun rng-c-parse-decls () + (setq rng-c-default-namespace-declared nil) + (while (progn + (let ((binding + (assoc rng-c-current-token + '(("namespace" . rng-c-parse-namespace) + ("datatypes" . rng-c-parse-datatypes) + ("default" . rng-c-parse-default))))) + (if binding + (progn + (rng-c-advance) + (funcall (cdr binding)) + t) + nil)))) + (rng-c-declare-standard-datatypes) + (rng-c-declare-standard-namespaces)) + +(defun rng-c-parse-datatypes () + (let ((prefix (rng-c-parse-identifier-or-keyword))) + (or (not (assoc prefix rng-c-datatype-decls)) + (rng-c-error "Duplicate datatypes declaration for prefix %s" prefix)) + (rng-c-expect "=") + (setq rng-c-datatype-decls + (cons (cons prefix + (rng-make-datatypes-uri (rng-c-parse-literal))) + rng-c-datatype-decls)))) + +(defun rng-c-parse-namespace () + (rng-c-declare-namespace nil + (rng-c-parse-identifier-or-keyword))) + +(defun rng-c-parse-default () + (rng-c-expect "namespace") + (rng-c-declare-namespace t + (if (string-equal rng-c-current-token "=") + nil + (rng-c-parse-identifier-or-keyword)))) + +(defun rng-c-declare-namespace (declare-default prefix) + (rng-c-expect "=") + (let ((ns (cond ((string-equal rng-c-current-token "inherit") + (rng-c-advance) + rng-c-inherit-namespace) + (t + (nxml-make-namespace (rng-c-parse-literal)))))) + (and prefix + (or (not (assoc prefix rng-c-namespace-decls)) + (rng-c-error "Duplicate namespace declaration for prefix %s" + prefix)) + (setq rng-c-namespace-decls + (cons (cons prefix ns) rng-c-namespace-decls))) + (and declare-default + (or (not rng-c-default-namespace-declared) + (rng-c-error "Duplicate default namespace declaration")) + (setq rng-c-default-namespace-declared t) + (setq rng-c-default-namespace ns)))) + +(defun rng-c-parse-implicit-grammar () + (let* ((rng-c-parent-grammar rng-c-current-grammar) + (rng-c-current-grammar (rng-c-make-grammar))) + (rng-c-parse-grammar-body "") + (rng-c-finish-grammar))) + +(defun rng-c-parse-grammar-body (close-token &optional in-include) + (while (not (string-equal rng-c-current-token close-token)) + (cond ((rng-c-current-token-keyword-p) + (let ((kw (intern rng-c-current-token))) + (cond ((eq kw 'start) + (rng-c-parse-define 'start in-include)) + ((eq kw 'div) + (rng-c-advance) + (rng-c-parse-div in-include)) + ((eq kw 'include) + (and in-include + (rng-c-error "Nested include")) + (rng-c-advance) + (rng-c-parse-include)) + (t (rng-c-error "Invalid grammar keyword"))))) + ((rng-c-current-token-ncname-p) + (if (looking-at "\\[") + (rng-c-parse-annotation-element) + (rng-c-parse-define rng-c-current-token + in-include))) + ((rng-c-current-token-quoted-identifier-p) + (if (looking-at "\\[") + (rng-c-parse-annotation-element) + (rng-c-parse-define (substring rng-c-current-token 1) + in-include))) + ((rng-c-current-token-prefixed-name-p) + (rng-c-parse-annotation-element)) + ((string-equal rng-c-current-token "[") + (rng-c-parse-lead-annotation) + (and (string-equal rng-c-current-token close-token) + (rng-c-error "Missing annotation subject")) + (and (looking-at "\\[") + (rng-c-error "Leading annotation applied to annotation"))) + (t (rng-c-error "Invalid grammar content")))) + (or (string-equal rng-c-current-token "") + (rng-c-advance))) + +(defun rng-c-parse-div (in-include) + (rng-c-expect "{") + (rng-c-parse-grammar-body "}" in-include)) + +(defun rng-c-parse-include () + (let* ((filename (rng-c-expand-file (rng-c-parse-literal))) + (rng-c-inherit-namespace (rng-c-parse-opt-inherit)) + overrides) + (cond ((string-equal rng-c-current-token "{") + (rng-c-advance) + (let ((rng-c-overrides nil)) + (rng-c-parse-grammar-body "}" t) + (setq overrides rng-c-overrides)) + (setq overrides (rng-c-start-include overrides)) + (rng-c-parse-file filename 'include) + (rng-c-end-include overrides)) + (t (rng-c-parse-file filename 'include))))) + +(defun rng-c-parse-define (name in-include) + (rng-c-advance) + (let ((assign (assoc rng-c-current-token + '(("=" . nil) + ("|=" . choice) + ("&=" . interleave))))) + (or assign + (rng-c-error "Expected assignment operator")) + (rng-c-advance) + (let ((ref (rng-c-prepare-define name (cdr assign) in-include))) + (rng-c-define ref (rng-c-parse-pattern))))) + +(defvar rng-c-had-except nil) + +(defun rng-c-parse-pattern () + (let* ((rng-c-had-except nil) + (p (rng-c-parse-repeated)) + (op (assoc rng-c-current-token + '(("|" . rng-make-choice) + ("," . rng-make-group) + ("&" . rng-make-interleave))))) + (if op + (if rng-c-had-except + (rng-c-error "Parentheses required around pattern using -") + (let* ((patterns (cons p nil)) + (tail patterns) + (connector rng-c-current-token)) + (while (progn + (rng-c-advance) + (let ((newcdr (cons (rng-c-parse-repeated) nil))) + (setcdr tail newcdr) + (setq tail newcdr)) + (string-equal rng-c-current-token connector))) + (funcall (cdr op) patterns))) + p))) + +(defun rng-c-parse-repeated () + (let ((p (rng-c-parse-follow-annotations + (rng-c-parse-primary))) + (op (assoc rng-c-current-token + '(("*" . rng-make-zero-or-more) + ("+" . rng-make-one-or-more) + ("?" . rng-make-optional))))) + (if op + (if rng-c-had-except + (rng-c-error "Parentheses required around pattern using -") + (rng-c-parse-follow-annotations + (progn + (rng-c-advance) + (funcall (cdr op) p)))) + p))) + +(defun rng-c-parse-primary () + "Parse a primary expression. The current token must be the first +token of the expression. After parsing the current token should be +token following the primary expression." + (cond ((rng-c-current-token-keyword-p) + (let ((parse-function (get (intern rng-c-current-token) + 'rng-c-pattern))) + (or parse-function + (rng-c-error "Keyword %s does not introduce a pattern" + rng-c-current-token)) + (rng-c-advance) + (funcall parse-function))) + ((rng-c-current-token-ncname-p) + (rng-c-advance-with (rng-c-make-ref rng-c-current-token))) + ((string-equal rng-c-current-token "(") + (rng-c-advance) + (let ((p (rng-c-parse-pattern))) + (rng-c-expect ")") + p)) + ((rng-c-current-token-prefixed-name-p) + (let ((name (rng-c-expand-datatype rng-c-current-token))) + (rng-c-advance) + (rng-c-parse-data name))) + ((rng-c-current-token-literal-p) + (rng-make-value rng-token-datatype (rng-c-parse-literal) nil)) + ((rng-c-current-token-quoted-identifier-p) + (rng-c-advance-with + (rng-c-make-ref (substring rng-c-current-token 1)))) + ((string-equal rng-c-current-token "[") + (rng-c-parse-lead-annotation) + (rng-c-parse-primary)) + (t (rng-c-error "Invalid pattern")))) + +(defun rng-c-parse-parent () + (and (rng-c-current-token-keyword-p) + (rng-c-error "Keyword following parent was not quoted" + rng-c-current-token)) + (rng-c-make-parent-ref (rng-c-parse-identifier-or-keyword))) + +(defun rng-c-parse-literal () + (rng-c-fix-escaped-newlines + (apply 'concat (rng-c-parse-literal-segments)))) + +(defun rng-c-parse-literal-segments () + (let ((str (rng-c-parse-literal-segment))) + (cons str + (cond ((string-equal rng-c-current-token "~") + (rng-c-advance) + (rng-c-parse-literal-segments)) + (t nil))))) + +(defun rng-c-parse-literal-segment () + (or (rng-c-current-token-literal-p) + (rng-c-error "Expected a literal")) + (rng-c-advance-with + (let ((n (if (and (>= (length rng-c-current-token) 6) + (eq (aref rng-c-current-token 0) + (aref rng-c-current-token 1))) + 3 + 1))) + (substring rng-c-current-token n (- n))))) + +(defun rng-c-fix-escaped-newlines (str) + (let ((pos 0)) + (while (progn + (let ((n (string-match "\C-@" str pos))) + (and n + (aset str n ?\n) + (setq pos (1+ n))))))) + str) + +(defun rng-c-parse-identifier-or-keyword () + (cond ((rng-c-current-token-ncname-p) + (rng-c-advance-with rng-c-current-token)) + ((rng-c-current-token-quoted-identifier-p) + (rng-c-advance-with (substring rng-c-current-token 1))) + (t (rng-c-error "Expected identifier or keyword")))) + +(put 'string 'rng-c-pattern 'rng-c-parse-string) +(put 'token 'rng-c-pattern 'rng-c-parse-token) +(put 'element 'rng-c-pattern 'rng-c-parse-element) +(put 'attribute 'rng-c-pattern 'rng-c-parse-attribute) +(put 'list 'rng-c-pattern 'rng-c-parse-list) +(put 'mixed 'rng-c-pattern 'rng-c-parse-mixed) +(put 'text 'rng-c-pattern 'rng-c-parse-text) +(put 'empty 'rng-c-pattern 'rng-c-parse-empty) +(put 'notAllowed 'rng-c-pattern 'rng-c-parse-not-allowed) +(put 'grammar 'rng-c-pattern 'rng-c-parse-grammar) +(put 'parent 'rng-c-pattern 'rng-c-parse-parent) +(put 'external 'rng-c-pattern 'rng-c-parse-external) + +(defun rng-c-parse-element () + (let ((name-class (rng-c-parse-name-class nil))) + (rng-c-expect "{") + (let ((pattern (rng-c-parse-pattern))) + (rng-c-expect "}") + (rng-make-element name-class pattern)))) + +(defun rng-c-parse-attribute () + (let ((name-class (rng-c-parse-name-class 'attribute))) + (rng-c-expect "{") + (let ((pattern (rng-c-parse-pattern))) + (rng-c-expect "}") + (rng-make-attribute name-class pattern)))) + +(defun rng-c-parse-name-class (attribute) + (let* ((rng-c-had-except nil) + (name-class + (rng-c-parse-follow-annotations + (rng-c-parse-primary-name-class attribute)))) + (if (string-equal rng-c-current-token "|") + (let* ((name-classes (cons name-class nil)) + (tail name-classes)) + (or (not rng-c-had-except) + (rng-c-error "Parentheses required around name-class using - operator")) + (while (progn + (rng-c-advance) + (let ((newcdr + (cons (rng-c-parse-follow-annotations + (rng-c-parse-primary-name-class attribute)) + nil))) + (setcdr tail newcdr) + (setq tail newcdr)) + (string-equal rng-c-current-token "|"))) + (rng-make-choice-name-class name-classes)) + name-class))) + +(defun rng-c-parse-primary-name-class (attribute) + (cond ((rng-c-current-token-ncname-p) + (rng-c-advance-with + (rng-make-name-name-class + (rng-make-name (rng-c-unqualified-namespace attribute) + rng-c-current-token)))) + ((rng-c-current-token-prefixed-name-p) + (rng-c-advance-with + (rng-make-name-name-class + (rng-c-expand-name rng-c-current-token)))) + ((string-equal rng-c-current-token "*") + (let ((except (rng-c-parse-opt-except-name-class attribute))) + (if except + (rng-make-any-name-except-name-class except) + (rng-make-any-name-name-class)))) + ((rng-c-current-token-ns-name-p) + (let* ((ns + (rng-c-lookup-prefix (substring rng-c-current-token + 0 + -2))) + (except (rng-c-parse-opt-except-name-class attribute))) + (if except + (rng-make-ns-name-except-name-class ns except) + (rng-make-ns-name-name-class ns)))) + ((string-equal rng-c-current-token "(") + (rng-c-advance) + (let ((name-class (rng-c-parse-name-class attribute))) + (rng-c-expect ")") + name-class)) + ((rng-c-current-token-quoted-identifier-p) + (rng-c-advance-with + (rng-make-name-name-class + (rng-make-name (rng-c-unqualified-namespace attribute) + (substring rng-c-current-token 1))))) + ((string-equal rng-c-current-token "[") + (rng-c-parse-lead-annotation) + (rng-c-parse-primary-name-class attribute)) + (t (rng-c-error "Bad name class")))) + +(defun rng-c-parse-opt-except-name-class (attribute) + (rng-c-advance) + (and (string-equal rng-c-current-token "-") + (or (not rng-c-had-except) + (rng-c-error "Parentheses required around name-class using - operator")) + (setq rng-c-had-except t) + (progn + (rng-c-advance) + (rng-c-parse-primary-name-class attribute)))) + +(defun rng-c-parse-mixed () + (rng-c-expect "{") + (let ((pattern (rng-make-mixed (rng-c-parse-pattern)))) + (rng-c-expect "}") + pattern)) + +(defun rng-c-parse-list () + (rng-c-expect "{") + (let ((pattern (rng-make-list (rng-c-parse-pattern)))) + (rng-c-expect "}") + pattern)) + +(defun rng-c-parse-text () + (rng-make-text)) + +(defun rng-c-parse-empty () + (rng-make-empty)) + +(defun rng-c-parse-not-allowed () + (rng-make-not-allowed)) + +(defun rng-c-parse-string () + (rng-c-parse-data rng-string-datatype)) + +(defun rng-c-parse-token () + (rng-c-parse-data rng-token-datatype)) + +(defun rng-c-parse-data (name) + (if (rng-c-current-token-literal-p) + (rng-make-value name + (rng-c-parse-literal) + (and (car name) + (rng-c-make-context))) + (let ((params (rng-c-parse-optional-params))) + (if (string-equal rng-c-current-token "-") + (progn + (if rng-c-had-except + (rng-c-error "Parentheses required around pattern using -") + (setq rng-c-had-except t)) + (rng-c-advance) + (rng-make-data-except name + params + (rng-c-parse-primary))) + (rng-make-data name params))))) + +(defun rng-c-parse-optional-params () + (and (string-equal rng-c-current-token "{") + (let* ((head (cons nil nil)) + (tail head)) + (rng-c-advance) + (while (not (string-equal rng-c-current-token "}")) + (and (string-equal rng-c-current-token "[") + (rng-c-parse-lead-annotation)) + (let ((name (rng-c-parse-identifier-or-keyword))) + (rng-c-expect "=") + (let ((newcdr (cons (cons (intern name) + (rng-c-parse-literal)) + nil))) + (setcdr tail newcdr) + (setq tail newcdr)))) + (rng-c-advance) + (cdr head)))) + +(defun rng-c-parse-external () + (let* ((filename (rng-c-expand-file (rng-c-parse-literal))) + (rng-c-inherit-namespace (rng-c-parse-opt-inherit))) + (rng-c-parse-file filename 'external))) + +(defun rng-c-expand-file (uri) + (condition-case err + (rng-uri-file-name (rng-uri-resolve uri + (rng-file-name-uri rng-c-file-name))) + (rng-uri-error + (rng-c-error (cadr err))))) + +(defun rng-c-parse-opt-inherit () + (cond ((string-equal rng-c-current-token "inherit") + (rng-c-advance) + (rng-c-expect "=") + (rng-c-lookup-prefix (rng-c-parse-identifier-or-keyword))) + (t rng-c-default-namespace))) + +(defun rng-c-parse-grammar () + (rng-c-expect "{") + (let* ((rng-c-parent-grammar rng-c-current-grammar) + (rng-c-current-grammar (rng-c-make-grammar))) + (rng-c-parse-grammar-body "}") + (rng-c-finish-grammar))) + +(defun rng-c-parse-lead-annotation () + (rng-c-parse-annotation-body) + (and (string-equal rng-c-current-token "[") + (rng-c-error "Multiple leading annotations"))) + +(defun rng-c-parse-follow-annotations (obj) + (while (string-equal rng-c-current-token ">>") + (rng-c-advance) + (if (rng-c-current-token-prefixed-name-p) + (rng-c-advance) + (rng-c-parse-identifier-or-keyword)) + (rng-c-parse-annotation-body t)) + obj) + +(defun rng-c-parse-annotation-element () + (rng-c-advance) + (rng-c-parse-annotation-body t)) + +;; XXX need stricter checking of attribute names +;; XXX don't allow attributes after text + +(defun rng-c-parse-annotation-body (&optional allow-text) + "Current token is [. Parse up to matching ]. Current token after +parse is token following ]." + (or (string-equal rng-c-current-token "[") + (rng-c-error "Expected [")) + (rng-c-advance) + (while (not (string-equal rng-c-current-token "]")) + (cond ((rng-c-current-token-literal-p) + (or allow-text + (rng-c-error "Out of place text within annotation")) + (rng-c-parse-literal)) + (t + (if (rng-c-current-token-prefixed-name-p) + (rng-c-advance) + (rng-c-parse-identifier-or-keyword)) + (cond ((string-equal rng-c-current-token "[") + (rng-c-parse-annotation-body t)) + ((string-equal rng-c-current-token "=") + (rng-c-advance) + (rng-c-parse-literal)) + (t (rng-c-error "Expected = or [")))))) + (rng-c-advance)) + +(defun rng-c-advance-with (pattern) + (rng-c-advance) + pattern) + +(defun rng-c-expect (str) + (or (string-equal rng-c-current-token str) + (rng-c-error "Expected `%s' but got `%s'" str rng-c-current-token)) + (rng-c-advance)) + +(provide 'rng-cmpct) + +;;; rng-cmpct.el + +;; arch-tag: 90395eb1-283b-4146-bbc1-6d6ef1704e57 diff --git a/lisp/nxml/rng-dt.el b/lisp/nxml/rng-dt.el new file mode 100644 index 00000000000..2ed8e19c7d9 --- /dev/null +++ b/lisp/nxml/rng-dt.el @@ -0,0 +1,67 @@ +;;; rng-dt.el --- datatype library interface for RELAX NG + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(require 'rng-util) + +(defvar rng-dt-error-reporter nil) + +(defun rng-dt-error (string &rest objs) + (if rng-dt-error-reporter + (apply rng-dt-error-reporter (cons string objs)) + nil)) + +(defvar rng-dt-namespace-context-getter nil + "A list used by datatype libraries to expand names. The car of the +list is a symbol which is the name of a function. This function is +applied to the cdr of the list. The function must return a list whose +car is the default namespace and whose cdr is an alist of (PREFIX +. NAMESPACE) pairs, where PREFIX is a string and NAMESPACE is a +symbol. This must be dynamically bound before calling a datatype +library.") + +(defsubst rng-dt-make-value (dt str) + (apply (car dt) (cons str (cdr dt)))) + +(defun rng-dt-builtin-compile (name params) + (cond ((eq name 'string) + (if (null params) + '(t identity) + (rng-dt-error "The string datatype does not take any parameters"))) + ((eq name 'token) + (if (null params) + '(t rng-collapse-space) + (rng-dt-error "The token datatype does not take any parameters"))) + (t + (rng-dt-error "There is no built-in datatype %s" name)))) + +(put (rng-make-datatypes-uri "") 'rng-dt-compile 'rng-dt-builtin-compile) + +(provide 'rng-dt) + +;; arch-tag: 1dca90f1-8dae-4dd4-b61f-fade4452c014 +;;; rng-dt.el ends here diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el new file mode 100644 index 00000000000..fd56c4bb903 --- /dev/null +++ b/lisp/nxml/rng-loc.el @@ -0,0 +1,551 @@ +;;; rng-loc.el --- locate the schema to use for validation + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(require 'nxml-util) +(require 'nxml-parse) +(require 'rng-parse) +(require 'rng-uri) +(require 'rng-util) +(require 'xmltok) + +(defvar rng-current-schema-file-name nil + "Filename of schema being used for current buffer. +Nil if using a vacuous schema.") +(make-variable-buffer-local 'rng-current-schema-file-name) + +(defvar rng-schema-locating-files-default nil + "Default value for variable `rng-schema-locating-files'.") + +(defvar rng-schema-locating-file-schema-file nil + "File containing schema for schema locating files.") + +(defvar rng-schema-locating-file-schema nil + "Schema for schema locating files or nil if not yet loaded.") + +(defcustom rng-schema-locating-files rng-schema-locating-files-default + "*List of schema locating files." + :type '(repeat file) + :group 'relax-ng) + +(defvar rng-schema-loader-alist nil + "Alist of schema extensions vs schema loader functions.") + +(defvar rng-cached-document-element nil) + +(defvar rng-document-type-history nil) + +(defun rng-set-document-type (type-id) + (interactive (list (rng-read-type-id))) + (condition-case err + (when (not (string= type-id "")) + (let ((schema-file (rng-locate-schema-file type-id))) + (unless schema-file + (error "Could not locate schema for type id `%s'" type-id)) + (rng-set-schema-file-1 schema-file)) + (rng-save-schema-location-1 t type-id) + (rng-what-schema)) + (nxml-file-parse-error + (nxml-display-file-parse-error err)))) + +(defun rng-read-type-id () + (condition-case err + (let ((type-ids (rng-possible-type-ids)) + (completion-ignore-case nil)) + (completing-read "Document type id: " + (mapcar (lambda (x) (cons x nil)) + type-ids) + nil + t + nil + 'rng-document-type-history)) + (nxml-file-parse-error + (nxml-display-file-parse-error err)))) + +(defun rng-set-schema-file (filename) + "Set the schema for the current buffer to the schema in FILENAME. +FILENAME must be the name of a file containing a schema. +The extension of FILENAME is used to determine what kind of schema it +is. The variable `rng-schema-loader-alist' maps from schema +extensions to schema loader functions. The function +`rng-c-load-schema' is the loader for RELAX NG compact syntax. The +association is between the buffer and the schema: the association is +lost when the buffer is killed." + (interactive "fSchema file: ") + (condition-case err + (progn + (rng-set-schema-file-1 filename) + (rng-save-schema-location-1 t)) + (nxml-file-parse-error + (nxml-display-file-parse-error err)))) + +(defun rng-set-vacuous-schema () + "Set the schema for the current buffer to allow any well-formed XML." + (interactive) + (rng-set-schema-file-1 nil) + (rng-what-schema)) + +(defun rng-set-schema-file-1 (filename) + (setq filename (and filename (expand-file-name filename))) + (setq rng-current-schema + (if filename + (rng-load-schema filename) + rng-any-element)) + (setq rng-current-schema-file-name filename) + (run-hooks 'rng-schema-change-hook)) + +(defun rng-load-schema (filename) + (let* ((extension (file-name-extension filename)) + (loader (cdr (assoc extension rng-schema-loader-alist)))) + (or loader + (if extension + (error "No schema loader available for file extension `%s'" + extension) + (error "No schema loader available for null file extension"))) + (funcall loader filename))) + +(defun rng-what-schema () + "Display a message saying what schema `rng-validate-mode' is using." + (interactive) + (if rng-current-schema-file-name + (message "Using schema %s" + (abbreviate-file-name rng-current-schema-file-name)) + (message "Using vacuous schema"))) + +(defun rng-auto-set-schema (&optional no-display-error) + "Set the schema for this buffer based on the buffer's contents and file-name." + (interactive) + (condition-case err + (progn + (rng-set-schema-file-1 (rng-locate-schema-file)) + (rng-what-schema)) + (nxml-file-parse-error + (if no-display-error + (error "%s at position %s in %s" + (nth 3 err) + (nth 2 err) + (abbreviate-file-name (nth 1 err))) + (nxml-display-file-parse-error err))))) + +(defun rng-locate-schema-file (&optional type-id) + "Return the file-name of the schema to use for the current buffer. +Return nil if no schema could be located. +If TYPE-ID is non-nil, then locate the schema for this TYPE-ID." + (let* ((rng-cached-document-element nil) + (schema + (if type-id + (cons type-id nil) + (rng-locate-schema-file-using rng-schema-locating-files))) + files type-ids) + (while (consp schema) + (setq files rng-schema-locating-files) + (setq type-id (car schema)) + (setq schema nil) + (when (member type-id type-ids) + (error "Type-id loop for type-id `%s'" type-id)) + (setq type-ids (cons type-id type-ids)) + (while (and files (not schema)) + (setq schema + (rng-locate-schema-file-from-type-id type-id + (car files))) + (setq files (cdr files)))) + (and schema + (rng-uri-file-name schema)))) + +(defun rng-possible-type-ids () + "Return a list of the known type IDs." + (let ((files rng-schema-locating-files) + type-ids) + (while files + (setq type-ids (rng-possible-type-ids-using (car files) type-ids)) + (setq files (cdr files))) + (rng-uniquify-equal (sort type-ids 'string<)))) + +(defun rng-locate-schema-file-using (files) + "Locate a schema using the schema locating files FILES. +FILES is a list of file-names. +Return either a URI, a list (TYPE-ID) where TYPE-ID is a string +or nil." + (let (rules + ;; List of types that override normal order-based + ;; priority, most important first + preferred-types + ;; Best result found so far; same form as return value. + best-so-far) + (while (and (progn + (while (and (not rules) files) + (setq rules (rng-get-parsed-schema-locating-file + (car files))) + (setq files (cdr files))) + rules) + (or (not best-so-far) preferred-types)) + (let* ((rule (car rules)) + (rule-type (car rule)) + (rule-matcher (get rule-type 'rng-rule-matcher))) + (setq rules (cdr rules)) + (cond (rule-matcher + (when (and (or (not best-so-far) + (memq rule-type preferred-types))) + (setq best-so-far + (funcall rule-matcher (cdr rule))) + preferred-types) + (setq preferred-types + (nbutlast preferred-types + (length (memq rule-type preferred-types))))) + ((eq rule-type 'applyFollowingRules) + (when (not best-so-far) + (let ((prefer (cdr (assq 'ruleType (cdr rule))))) + (when (and prefer + (not (memq (setq prefer (intern prefer)) + preferred-types))) + (setq preferred-types + (nconc preferred-types (list prefer))))))) + ((eq rule-type 'include) + (let ((uri (cdr (assq 'rules (cdr rule))))) + (when uri + (setq rules + (append (rng-get-parsed-schema-locating-file + (rng-uri-file-name uri)) + rules)))))))) + best-so-far)) + +(put 'documentElement 'rng-rule-matcher 'rng-match-document-element-rule) +(put 'namespace 'rng-rule-matcher 'rng-match-namespace-rule) +(put 'uri 'rng-rule-matcher 'rng-match-uri-rule) +(put 'transformURI 'rng-rule-matcher 'rng-match-transform-uri-rule) +(put 'default 'rng-rule-matcher 'rng-match-default-rule) + +(defun rng-match-document-element-rule (props) + (let ((document-element (rng-document-element)) + (prefix (cdr (assq 'prefix props))) + (local-name (cdr (assq 'localName props)))) + (and (or (not prefix) + (if (= (length prefix) 0) + (not (nth 1 document-element)) + (string= prefix (nth 1 document-element)))) + (or (not local-name) + (string= local-name + (nth 2 document-element))) + (rng-match-default-rule props)))) + +(defun rng-match-namespace-rule (props) + (let ((document-element (rng-document-element)) + (ns (cdr (assq 'ns props)))) + (and document-element + ns + (eq (nth 0 document-element) + (if (string= ns "") + nil + (nxml-make-namespace ns))) + (rng-match-default-rule props)))) + +(defun rng-document-element () + "Return a list (NS PREFIX LOCAL-NAME). +NS is t if the document has a non-nil, but not otherwise known namespace." + (or rng-cached-document-element + (setq rng-cached-document-element + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let (xmltok-dtd) + (xmltok-save + (xmltok-forward-prolog) + (xmltok-forward) + (when (memq xmltok-type '(start-tag + partial-start-tag + empty-element + partial-empty-element)) + (list (rng-get-start-tag-namespace) + (xmltok-start-tag-prefix) + (xmltok-start-tag-local-name)))))))))) + +(defun rng-get-start-tag-namespace () + (let ((prefix (xmltok-start-tag-prefix)) + namespace att value) + (while xmltok-namespace-attributes + (setq att (car xmltok-namespace-attributes)) + (setq xmltok-namespace-attributes (cdr xmltok-namespace-attributes)) + (when (if prefix + (and (xmltok-attribute-prefix att) + (string= (xmltok-attribute-local-name att) + prefix)) + (not (xmltok-attribute-prefix att))) + (setq value (xmltok-attribute-value att)) + (setq namespace (if value (nxml-make-namespace value) t)))) + (if (and prefix (not namespace)) + t + namespace))) + +(defun rng-match-transform-uri-rule (props) + (let ((from-pattern (cdr (assq 'fromPattern props))) + (to-pattern (cdr (assq 'toPattern props))) + (file-name (buffer-file-name))) + (and file-name + (setq file-name (expand-file-name file-name)) + (rng-file-name-matches-uri-pattern-p file-name from-pattern) + (condition-case () + (let ((new-file-name + (replace-match + (save-match-data + (rng-uri-pattern-file-name-replace-match to-pattern)) + t + nil + file-name))) + (and (file-name-absolute-p new-file-name) + (file-exists-p new-file-name) + (rng-file-name-uri new-file-name))) + (rng-uri-error nil))))) + +(defun rng-match-uri-rule (props) + (let ((resource (cdr (assq 'resource props))) + (pattern (cdr (assq 'pattern props))) + (file-name (buffer-file-name))) + (and file-name + (setq file-name (expand-file-name file-name)) + (cond (resource + (condition-case () + (eq (compare-strings (rng-uri-file-name resource) + 0 + nil + (expand-file-name file-name) + 0 + nil + nxml-file-name-ignore-case) + t) + (rng-uri-error nil))) + (pattern + (rng-file-name-matches-uri-pattern-p file-name + pattern))) + (rng-match-default-rule props)))) + +(defun rng-file-name-matches-uri-pattern-p (file-name pattern) + (condition-case () + (and (let ((case-fold-search nxml-file-name-ignore-case)) + (string-match (rng-uri-pattern-file-name-regexp pattern) + file-name)) + t) + (rng-uri-error nil))) + +(defun rng-match-default-rule (props) + (or (cdr (assq 'uri props)) + (let ((type-id (cdr (assq 'typeId props)))) + (and type-id + (cons (rng-collapse-space type-id) nil))))) + +(defun rng-possible-type-ids-using (file type-ids) + (let ((rules (rng-get-parsed-schema-locating-file file)) + rule) + (while rules + (setq rule (car rules)) + (setq rules (cdr rules)) + (cond ((eq (car rule) 'typeId) + (let ((id (cdr (assq 'id (cdr rule))))) + (when id + (setq type-ids + (cons (rng-collapse-space id) + type-ids))))) + ((eq (car rule) 'include) + (let ((uri (cdr (assq 'rules (cdr rule))))) + (when uri + (setq type-ids + (rng-possible-type-ids-using + (rng-get-parsed-schema-locating-file + (rng-uri-file-name uri)) + type-ids))))))) + type-ids)) + +(defun rng-locate-schema-file-from-type-id (type-id file) + "Locate the schema for type id TYPE-ID using schema locating file FILE. +Return either a URI, a list (TYPE-ID) where TYPE-ID is a string +or nil." + (let ((rules (rng-get-parsed-schema-locating-file file)) + schema rule) + (while (and rules (not schema)) + (setq rule (car rules)) + (setq rules (cdr rules)) + (cond ((and (eq (car rule) 'typeId) + (let ((id (assq 'id (cdr rule)))) + (and id + (string= (rng-collapse-space (cdr id)) type-id)))) + (setq schema (rng-match-default-rule (cdr rule)))) + ((eq (car rule) 'include) + (let ((uri (cdr (assq 'rules (cdr rule))))) + (when uri + (setq schema + (rng-locate-schema-file-from-type-id + type-id + (rng-uri-file-name uri)))))))) + schema)) + +(defvar rng-schema-locating-file-alist nil) + +(defun rng-get-parsed-schema-locating-file (file) + "Return a list of rules for the schema locating file FILE." + (setq file (expand-file-name file)) + (let ((cached (assoc file rng-schema-locating-file-alist)) + (mtime (nth 5 (file-attributes file))) + parsed) + (cond ((not mtime) + (when cached + (setq rng-schema-locating-file-alist + (delq cached rng-schema-locating-file-alist))) + nil) + ((and cached (equal (nth 1 cached) mtime)) + (nth 2 cached)) + (t + (setq parsed (rng-parse-schema-locating-file file)) + (if cached + (setcdr cached (list mtime parsed)) + (setq rng-schema-locating-file-alist + (cons (list file mtime parsed) + rng-schema-locating-file-alist))) + parsed)))) + +(defconst rng-locate-namespace-uri + (nxml-make-namespace "http://thaiopensource.com/ns/locating-rules/1.0")) + +(defun rng-parse-schema-locating-file (file) + "Return list of rules. +Each rule has the form (TYPE (ATTR . VAL) ...), where +TYPE is a symbol for the element name, ATTR is a symbol for the attribute +and VAL is a string for the value. +Attribute values representing URIs are made absolute and xml:base +attributes are removed." + (when (and (not rng-schema-locating-file-schema) + rng-schema-locating-file-schema-file) + (setq rng-schema-locating-file-schema + (rng-load-schema rng-schema-locating-file-schema-file))) + (let* ((element + (if rng-schema-locating-file-schema + (rng-parse-validate-file rng-schema-locating-file-schema + file) + (nxml-parse-file file))) + (children (cddr element)) + (base-uri (rng-file-name-uri file)) + child name rules atts att props prop-name prop-value) + (when (equal (car element) + (cons rng-locate-namespace-uri "locatingRules")) + (while children + (setq child (car children)) + (setq children (cdr children)) + (when (consp child) + (setq name (car child)) + (when (eq (car name) rng-locate-namespace-uri) + (setq atts (cadr child)) + (setq props nil) + (while atts + (setq att (car atts)) + (when (stringp (car att)) + (setq prop-name (intern (car att))) + (setq prop-value (cdr att)) + (when (memq prop-name '(uri rules resource)) + (setq prop-value + (rng-uri-resolve prop-value base-uri))) + (setq props (cons (cons prop-name prop-value) + props))) + (setq atts (cdr atts))) + (setq rules + (cons (cons (intern (cdr name)) (nreverse props)) + rules)))))) + (nreverse rules))) + +(defun rng-save-schema-location () + "Save the association between the buffer's file and the current schema. +This ensures that the schema that is currently being used will be used +if the file is edited in a future session. The association will be +saved to the first writable file in `rng-schema-locating-files'." + (interactive) + (rng-save-schema-location-1 nil)) + +(defun rng-save-schema-location-1 (prompt &optional type-id) + (unless (or rng-current-schema-file-name type-id) + (error "Buffer is using a vacuous schema")) + (let ((files rng-schema-locating-files) + (document-file-name (buffer-file-name)) + (schema-file-name rng-current-schema-file-name) + file) + (while (and files (not file)) + (if (file-writable-p (car files)) + (setq file (expand-file-name (car files))) + (setq files (cdr files)))) + (cond ((not file) + (if prompt + nil + (error "No writable schema locating file configured"))) + ((not document-file-name) + (if prompt + nil + (error "Buffer does not have a filename"))) + ((and prompt + (not (y-or-n-p (format "Save %s to %s " + (if type-id + "type identifier" + "schema location") + file))))) + (t + (save-excursion + (set-buffer (find-file-noselect file)) + (let ((modified (buffer-modified-p))) + (if (> (buffer-size) 0) + (let (xmltok-dtd) + (goto-char (point-min)) + (xmltok-save + (xmltok-forward-prolog) + (xmltok-forward) + (unless (eq xmltok-type 'start-tag) + (error "Locating file `%s' invalid" file)))) + (insert "<?xml version=\"1.0\"?>\n" + "<locatingRules xmlns=\"" + (nxml-namespace-name rng-locate-namespace-uri) + "\">") + (let ((pos (point))) + (insert "\n</locatingRules>\n") + (goto-char pos))) + (insert "\n") + (insert (let ((locating-file-uri (rng-file-name-uri file))) + (format "<uri resource=\"%s\" %s=\"%s\"/>" + (rng-escape-string + (rng-relative-uri + (rng-file-name-uri document-file-name) + locating-file-uri)) + (if type-id "typeId" "uri") + (rng-escape-string + (or type-id + (rng-relative-uri + (rng-file-name-uri schema-file-name) + locating-file-uri)))))) + (indent-according-to-mode) + (when (or (not modified) + (y-or-n-p (format "Save file %s " + (buffer-file-name)))) + (save-buffer)))))))) + +(provide 'rng-loc) + +;; arch-tag: 725cf968-37a2-418b-b47b-d5209871a9ab +;;; rng-loc.el ends here diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el new file mode 100644 index 00000000000..c4cf0fdfa45 --- /dev/null +++ b/lisp/nxml/rng-maint.el @@ -0,0 +1,354 @@ +;;; rng-maint.el --- commands for RELAX NG maintainers + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(require 'xmltok) +(require 'nxml-mode) +(require 'texnfo-upd) + +(defvar rng-dir (file-name-directory load-file-name)) + +(defconst rng-autoload-modules + '(xmltok + nxml-mode + nxml-uchnm + nxml-glyph + rng-cmpct + rng-maint + rng-valid + rng-xsd + rng-nxml)) + +;;;###autoload +(defun rng-update-autoloads () + "Update the autoloads in rng-auto.el." + (interactive) + (let* ((generated-autoload-file (expand-file-name "rng-auto.el" + rng-dir))) + (mapcar (lambda (x) + (update-file-autoloads + (expand-file-name (concat (symbol-name x) ".el") rng-dir))) + rng-autoload-modules))) + + +(defconst rng-compile-modules + '(xmltok + nxml-util + nxml-enc + nxml-glyph + nxml-rap + nxml-outln + nxml-mode + nxml-uchnm + nxml-ns + nxml-parse + nxml-maint + xsd-regexp + rng-util + rng-dt + rng-xsd + rng-uri + rng-pttrn + rng-cmpct + rng-match + rng-parse + rng-loc + rng-valid + rng-nxml + rng-maint)) + +;;;###autoload +(defun rng-byte-compile-load () + "Byte-compile and load all of the RELAX NG library in an appropriate order." + (interactive) + (mapcar (lambda (x) + (byte-compile-file (expand-file-name (concat (symbol-name x) ".el") + rng-dir) + t)) + rng-compile-modules)) + + +;;; Conversion from XML to texinfo. +;; This is all a hack and is just enough to make the conversion work. +;; It's not intended for public use. + +(defvar rng-manual-base "nxml-mode") +(defvar rng-manual-xml (concat rng-manual-base ".xml")) +(defvar rng-manual-texi (concat rng-manual-base ".texi")) +(defvar rng-manual-info (concat rng-manual-base ".info")) + +;;;###autoload +(defun rng-format-manual () + "Create manual.texi from manual.xml." + (interactive) + (let ((xml-buf (find-file-noselect (expand-file-name rng-manual-xml + rng-dir))) + (texi-buf (find-file-noselect (expand-file-name rng-manual-texi + rng-dir)))) + (save-excursion + (set-buffer texi-buf) + (erase-buffer) + (let ((standard-output texi-buf)) + (princ (format "\\input texinfo @c -*- texinfo -*-\n\ +@c %%**start of header\n\ +@setfilename %s\n\ +@settitle \n\ +@c %%**end of header\n" rng-manual-info)) + (set-buffer xml-buf) + (goto-char (point-min)) + (xmltok-save + (xmltok-forward-prolog) + (rng-process-tokens)) + (princ "\n@bye\n")) + (set-buffer texi-buf) + (rng-manual-fixup) + (texinfo-insert-node-lines (point-min) (point-max) t) + (texinfo-all-menus-update) + (save-buffer)))) + +(defun rng-manual-fixup () + (goto-char (point-min)) + (search-forward "@top ") + (let ((pos (point))) + (search-forward "\n") + (let ((title (buffer-substring-no-properties pos (1- (point))))) + (goto-char (point-min)) + (search-forward "@settitle ") + (insert title) + (search-forward "@node") + (goto-char (match-beginning 0)) + (insert "@dircategory Emacs\n" + "@direntry\n* " + title + ": (" + rng-manual-info + ").\n@end direntry\n\n")))) + +(defvar rng-manual-inline-elements '(kbd key samp code var emph uref point)) + +(defun rng-process-tokens () + (let ((section-depth 0) + ;; stack of per-element space treatment + ;; t means keep, nil means discard, fill means no blank lines + (keep-space-stack (list nil)) + (ignore-following-newline nil) + (want-blank-line nil) + name startp endp data keep-space-for-children) + (while (xmltok-forward) + (cond ((memq xmltok-type '(start-tag empty-element end-tag)) + (setq startp (memq xmltok-type '(start-tag empty-element))) + (setq endp (memq xmltok-type '(end-tag empty-element))) + (setq name (intern (if startp + (xmltok-start-tag-qname) + (xmltok-end-tag-qname)))) + (setq keep-space-for-children nil) + (setq ignore-following-newline nil) + (cond ((memq name rng-manual-inline-elements) + (when startp + (when want-blank-line + (rng-manual-output-force-blank-line) + (when (eq want-blank-line 'noindent) + (princ "@noindent\n")) + (setq want-blank-line nil)) + (setq keep-space-for-children t) + (princ (format "@%s{" name))) + (when endp (princ "}"))) + ((eq name 'ulist) + (when startp + (rng-manual-output-force-blank-line) + (setq want-blank-line nil) + (princ "@itemize @bullet\n")) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line 'noindent) + (princ "@end itemize\n"))) + ((eq name 'item) + (rng-manual-output-force-new-line) + (setq want-blank-line endp) + (when startp (princ "@item\n"))) + ((memq name '(example display)) + (when startp + (setq ignore-following-newline t) + (rng-manual-output-force-blank-line) + (setq want-blank-line nil) + (setq keep-space-for-children t) + (princ (format "@%s\n" name))) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line 'noindent) + (princ (format "@end %s\n" name)))) + ((eq name 'para) + (rng-manual-output-force-new-line) + (when startp + (when want-blank-line + (setq want-blank-line t)) + (setq keep-space-for-children 'fill)) + (when endp (setq want-blank-line t))) + ((eq name 'section) + (when startp + (rng-manual-output-force-blank-line) + (when (eq section-depth 0) + (princ "@node Top\n")) + (princ "@") + (princ (nth section-depth '(top + chapter + section + subsection + subsubsection))) + (princ " ") + (setq want-blank-line nil) + (setq section-depth (1+ section-depth))) + (when endp + (rng-manual-output-force-new-line) + (setq want-blank-line nil) + (setq section-depth (1- section-depth)))) + ((eq name 'title) + (when startp + (setq keep-space-for-children 'fill)) + (when endp + (setq want-blank-line t) + (princ "\n")))) + (when startp + (setq keep-space-stack (cons keep-space-for-children + keep-space-stack))) + (when endp + (setq keep-space-stack (cdr keep-space-stack)))) + ((memq xmltok-type '(data + space + char-ref + entity-ref + cdata-section)) + (setq data nil) + (cond ((memq xmltok-type '(data space)) + (setq data (buffer-substring-no-properties xmltok-start + (point)))) + ((and (memq xmltok-type '(char-ref entity-ref)) + xmltok-replacement) + (setq data xmltok-replacement)) + ((eq xmltok-type 'cdata-section) + (setq data + (buffer-substring-no-properties (+ xmltok-start 9) + (- (point) 3))))) + (when (and data (car keep-space-stack)) + (setq data (replace-regexp-in-string "[@{}]" + "@\\&" + data + t)) + (when ignore-following-newline + (setq data (replace-regexp-in-string "\\`\n" "" data t))) + (setq ignore-following-newline nil) +;; (when (eq (car keep-space-stack) 'fill) +;; (setq data (replace-regexp-in-string "\n" " " data t))) + (when (eq want-blank-line 'noindent) + (setq data (replace-regexp-in-string "\\`\n*" "" data t))) + (when (> (length data) 0) + (when want-blank-line + (rng-manual-output-force-blank-line) + (when (eq want-blank-line 'noindent) + (princ "@noindent\n")) + (setq want-blank-line nil)) + (princ data)))) + )))) + +(defun rng-manual-output-force-new-line () + (save-excursion + (set-buffer standard-output) + (unless (eq (char-before) ?\n) + (insert ?\n)))) + +(defun rng-manual-output-force-blank-line () + (save-excursion + (set-buffer standard-output) + (if (eq (char-before) ?\n) + (unless (eq (char-before (1- (point))) ?\n) + (insert ?\n)) + (insert "\n\n")))) + +;;; Versioning + +;;;###autoload +(defun rng-write-version () + (find-file "VERSION") + (erase-buffer) + (insert nxml-version "\n") + (save-buffer)) + +;;; Timing + +(defun rng-time-to-float (time) + (+ (* (nth 0 time) 65536.0) + (nth 1 time) + (/ (nth 2 time) 1000000.0))) + +(defun rng-time-function (function &rest args) + (let* ((start (current-time)) + (val (apply function args)) + (end (current-time))) + (message "%s ran in %g seconds" + function + (- (rng-time-to-float end) + (rng-time-to-float start))) + val)) + +(defun rng-time-tokenize-buffer () + (interactive) + (rng-time-function 'rng-tokenize-buffer)) + +(defun rng-tokenize-buffer () + (save-excursion + (goto-char (point-min)) + (xmltok-save + (xmltok-forward-prolog) + (while (xmltok-forward))))) + +(defun rng-time-validate-buffer () + (interactive) + (rng-time-function 'rng-validate-buffer)) + +(defvar rng-error-count) +(defvar rng-validate-up-to-date-end) +(declare-function rng-clear-cached-state "rng-valid" (start end)) +(declare-function rng-clear-overlays "rng-valid" (beg end)) +(declare-function rng-clear-conditional-region "rng-valid" ()) +(declare-function rng-do-some-validation "rng-valid" + (&optional continue-p-function)) + +(defun rng-validate-buffer () + (save-restriction + (widen) + (nxml-with-unmodifying-text-property-changes + (rng-clear-cached-state (point-min) (point-max))) + ;; 1+ to clear empty overlays at (point-max) + (rng-clear-overlays (point-min) (1+ (point-max)))) + (setq rng-validate-up-to-date-end 1) + (rng-clear-conditional-region) + (setq rng-error-count 0) + (while (rng-do-some-validation + (lambda () t)))) + +;; arch-tag: 4b8c6143-daac-4888-9c61-9bea6f935f17 +;;; rng-maint.el ends here diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el new file mode 100644 index 00000000000..eb79d999634 --- /dev/null +++ b/lisp/nxml/rng-match.el @@ -0,0 +1,1742 @@ +;;; rng-match.el --- matching of RELAX NG patterns against XML events + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This uses the algorithm described in +;; http://www.thaiopensource.com/relaxng/derivative.html +;; +;; The schema to be used is contained in the variable +;; rng-current-schema. It has the form described in the file +;; rng-pttrn.el. +;; +;;; Code: + +(require 'rng-pttrn) +(require 'rng-util) +(require 'rng-dt) + +(defvar rng-not-allowed-ipattern nil) +(defvar rng-empty-ipattern nil) +(defvar rng-text-ipattern nil) + +(defvar rng-compile-table nil) + +(defvar rng-being-compiled nil + "Contains a list of ref patterns currently being compiled. +Used to detect illegal recursive references.") + +(defvar rng-ipattern-table nil) + +(defvar rng-last-ipattern-index nil) + +(defvar rng-match-state nil + "An ipattern representing the current state of validation.") + +;;; Inline functions + +(defsubst rng-update-match-state (new-state) + (if (and (eq new-state rng-not-allowed-ipattern) + (not (eq rng-match-state rng-not-allowed-ipattern))) + nil + (setq rng-match-state new-state) + t)) + +;;; Interned patterns + +(eval-when-compile + (defun rng-ipattern-slot-accessor-name (slot-name) + (intern (concat "rng-ipattern-get-" + (symbol-name slot-name)))) + + (defun rng-ipattern-slot-setter-name (slot-name) + (intern (concat "rng-ipattern-set-" + (symbol-name slot-name))))) + +(defmacro rng-ipattern-defslot (slot-name index) + `(progn + (defsubst ,(rng-ipattern-slot-accessor-name slot-name) (ipattern) + (aref ipattern ,index)) + (defsubst ,(rng-ipattern-slot-setter-name slot-name) (ipattern value) + (aset ipattern ,index value)))) + +(rng-ipattern-defslot type 0) +(rng-ipattern-defslot index 1) +(rng-ipattern-defslot name-class 2) +(rng-ipattern-defslot datatype 2) +(rng-ipattern-defslot after 2) +(rng-ipattern-defslot child 3) +(rng-ipattern-defslot value-object 3) +(rng-ipattern-defslot nullable 4) +(rng-ipattern-defslot memo-text-typed 5) +(rng-ipattern-defslot memo-map-start-tag-open-deriv 6) +(rng-ipattern-defslot memo-map-start-attribute-deriv 7) +(rng-ipattern-defslot memo-start-tag-close-deriv 8) +(rng-ipattern-defslot memo-text-only-deriv 9) +(rng-ipattern-defslot memo-mixed-text-deriv 10) +(rng-ipattern-defslot memo-map-data-deriv 11) +(rng-ipattern-defslot memo-end-tag-deriv 12) + +(defconst rng-memo-map-alist-max 10) + +(defsubst rng-memo-map-get (key mm) + "Return the value associated with KEY in memo-map MM." + (let ((found (assoc key mm))) + (if found + (cdr found) + (and mm + (let ((head (car mm))) + (and (hash-table-p head) + (gethash key head))))))) + +(defun rng-memo-map-add (key value mm &optional weakness) + "Associate KEY with VALUE in memo-map MM and return the new memo-map. +The new memo-map may or may not be a different object from MM. + +Alists are better for small maps. Hash tables are better for large +maps. A memo-map therefore starts off as an alist and switches to a +hash table for large memo-maps. A memo-map is always a list. An empty +memo-map is represented by nil. A large memo-map is represented by a +list containing just a hash-table. A small memo map is represented by +a list whose cdr is an alist and whose car is the number of entries in +the alist. The complete memo-map can be passed to assoc without +problems: assoc ignores any members that are not cons cells. There is +therefore minimal overhead in successful lookups on small lists +\(which is the most common case)." + (if (null mm) + (list 1 (cons key value)) + (let ((head (car mm))) + (cond ((hash-table-p head) + (puthash key value head) + mm) + ((>= head rng-memo-map-alist-max) + (let ((ht (make-hash-table :test 'equal + :weakness weakness + :size (* 2 rng-memo-map-alist-max)))) + (setq mm (cdr mm)) + (while mm + (setq head (car mm)) + (puthash (car head) (cdr head) ht) + (setq mm (cdr mm))) + (cons ht nil))) + (t (cons (1+ head) + (cons (cons key value) + (cdr mm)))))))) + +(defsubst rng-make-ipattern (type index name-class child nullable) + (vector type index name-class child nullable + ;; 5 memo-text-typed + 'unknown + ;; 6 memo-map-start-tag-open-deriv + nil + ;; 7 memo-map-start-attribute-deriv + nil + ;; 8 memo-start-tag-close-deriv + nil + ;; 9 memo-text-only-deriv + nil + ;; 10 memo-mixed-text-deriv + nil + ;; 11 memo-map-data-deriv + nil + ;; 12 memo-end-tag-deriv + nil)) + +(defun rng-ipattern-maybe-init () + (unless rng-ipattern-table + (setq rng-ipattern-table (make-hash-table :test 'equal)) + (setq rng-last-ipattern-index -1))) + +(defun rng-ipattern-clear () + (when rng-ipattern-table + (clrhash rng-ipattern-table)) + (setq rng-last-ipattern-index -1)) + +(defsubst rng-gen-ipattern-index () + (setq rng-last-ipattern-index (1+ rng-last-ipattern-index))) + +(defun rng-put-ipattern (key type name-class child nullable) + (let ((ipattern + (rng-make-ipattern type + (rng-gen-ipattern-index) + name-class + child + nullable))) + (puthash key ipattern rng-ipattern-table) + ipattern)) + +(defun rng-get-ipattern (key) + (gethash key rng-ipattern-table)) + +(or rng-not-allowed-ipattern + (setq rng-not-allowed-ipattern + (rng-make-ipattern 'not-allowed -3 nil nil nil))) + +(or rng-empty-ipattern + (setq rng-empty-ipattern + (rng-make-ipattern 'empty -2 nil nil t))) + +(or rng-text-ipattern + (setq rng-text-ipattern + (rng-make-ipattern 'text -1 nil nil t))) + +(defconst rng-const-ipatterns + (list rng-not-allowed-ipattern + rng-empty-ipattern + rng-text-ipattern)) + +(defun rng-intern-after (child after) + (if (eq child rng-not-allowed-ipattern) + rng-not-allowed-ipattern + (let ((key (list 'after + (rng-ipattern-get-index child) + (rng-ipattern-get-index after)))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'after + after + child + nil))))) + +(defun rng-intern-attribute (name-class ipattern) + (if (eq ipattern rng-not-allowed-ipattern) + rng-not-allowed-ipattern + (let ((key (list 'attribute + name-class + (rng-ipattern-get-index ipattern)))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'attribute + name-class + ipattern + nil))))) + +(defun rng-intern-data (dt matches-anything) + (let ((key (list 'data dt))) + (or (rng-get-ipattern key) + (let ((ipattern (rng-put-ipattern key + 'data + dt + nil + matches-anything))) + (rng-ipattern-set-memo-text-typed ipattern + (not matches-anything)) + ipattern)))) + +(defun rng-intern-data-except (dt ipattern) + (let ((key (list 'data-except dt ipattern))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'data-except + dt + ipattern + nil)))) + +(defun rng-intern-value (dt obj) + (let ((key (list 'value dt obj))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'value + dt + obj + nil)))) + +(defun rng-intern-one-or-more (ipattern) + (or (rng-intern-one-or-more-shortcut ipattern) + (let ((key (cons 'one-or-more + (list (rng-ipattern-get-index ipattern))))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'one-or-more + nil + ipattern + (rng-ipattern-get-nullable ipattern)))))) + +(defun rng-intern-one-or-more-shortcut (ipattern) + (cond ((eq ipattern rng-not-allowed-ipattern) + rng-not-allowed-ipattern) + ((eq ipattern rng-empty-ipattern) + rng-empty-ipattern) + ((eq (rng-ipattern-get-type ipattern) 'one-or-more) + ipattern) + (t nil))) + +(defun rng-intern-list (ipattern) + (if (eq ipattern rng-not-allowed-ipattern) + rng-not-allowed-ipattern + (let ((key (cons 'list + (list (rng-ipattern-get-index ipattern))))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'list + nil + ipattern + nil))))) + +(defun rng-intern-group (ipatterns) + "Return a ipattern for the list of group members in IPATTERNS." + (or (rng-intern-group-shortcut ipatterns) + (let* ((tem (rng-normalize-group-list ipatterns)) + (normalized (cdr tem))) + (or (rng-intern-group-shortcut normalized) + (let ((key (cons 'group + (mapcar 'rng-ipattern-get-index normalized)))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'group + nil + normalized + (car tem)))))))) + +(defun rng-intern-group-shortcut (ipatterns) + "Try to shortcut interning a group list. If successful, return the +interned pattern. Otherwise return nil." + (while (and ipatterns + (eq (car ipatterns) rng-empty-ipattern)) + (setq ipatterns (cdr ipatterns))) + (if ipatterns + (let ((ret (car ipatterns))) + (if (eq ret rng-not-allowed-ipattern) + rng-not-allowed-ipattern + (setq ipatterns (cdr ipatterns)) + (while (and ipatterns ret) + (let ((tem (car ipatterns))) + (cond ((eq tem rng-not-allowed-ipattern) + (setq ret tem) + (setq ipatterns nil)) + ((eq tem rng-empty-ipattern) + (setq ipatterns (cdr ipatterns))) + (t + ;; Stop here rather than continuing + ;; looking for not-allowed patterns. + ;; We do a complete scan elsewhere. + (setq ret nil))))) + ret)) + rng-empty-ipattern)) + +(defun rng-normalize-group-list (ipatterns) + "Normalize a list containing members of a group. +Expands nested groups, removes empty members, handles notAllowed. +Returns a pair whose car says whether the list is nullable and whose +cdr is the normalized list." + (let ((nullable t) + (result nil) + member) + (while ipatterns + (setq member (car ipatterns)) + (setq ipatterns (cdr ipatterns)) + (when nullable + (setq nullable (rng-ipattern-get-nullable member))) + (cond ((eq (rng-ipattern-get-type member) 'group) + (setq result + (nconc (reverse (rng-ipattern-get-child member)) + result))) + ((eq member rng-not-allowed-ipattern) + (setq result (list rng-not-allowed-ipattern)) + (setq ipatterns nil)) + ((not (eq member rng-empty-ipattern)) + (setq result (cons member result))))) + (cons nullable (nreverse result)))) + +(defun rng-intern-interleave (ipatterns) + (or (rng-intern-group-shortcut ipatterns) + (let* ((tem (rng-normalize-interleave-list ipatterns)) + (normalized (cdr tem))) + (or (rng-intern-group-shortcut normalized) + (let ((key (cons 'interleave + (mapcar 'rng-ipattern-get-index normalized)))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'interleave + nil + normalized + (car tem)))))))) + +(defun rng-normalize-interleave-list (ipatterns) + "Normalize a list containing members of an interleave. +Expands nested groups, removes empty members, handles notAllowed. +Returns a pair whose car says whether the list is nullable and whose +cdr is the normalized list." + (let ((nullable t) + (result nil) + member) + (while ipatterns + (setq member (car ipatterns)) + (setq ipatterns (cdr ipatterns)) + (when nullable + (setq nullable (rng-ipattern-get-nullable member))) + (cond ((eq (rng-ipattern-get-type member) 'interleave) + (setq result + (append (rng-ipattern-get-child member) + result))) + ((eq member rng-not-allowed-ipattern) + (setq result (list rng-not-allowed-ipattern)) + (setq ipatterns nil)) + ((not (eq member rng-empty-ipattern)) + (setq result (cons member result))))) + (cons nullable (sort result 'rng-compare-ipattern)))) + +;; Would be cleaner if this didn't modify IPATTERNS. + +(defun rng-intern-choice (ipatterns) + "Return a choice ipattern for the list of choices in IPATTERNS. +May alter IPATTERNS." + (or (rng-intern-choice-shortcut ipatterns) + (let* ((tem (rng-normalize-choice-list ipatterns)) + (normalized (cdr tem))) + (or (rng-intern-choice-shortcut normalized) + (rng-intern-choice1 normalized (car tem)))))) + +(defun rng-intern-optional (ipattern) + (cond ((rng-ipattern-get-nullable ipattern) ipattern) + ((eq ipattern rng-not-allowed-ipattern) rng-empty-ipattern) + (t (rng-intern-choice1 + ;; This is sorted since the empty pattern + ;; is before everything except not allowed. + ;; It cannot have a duplicate empty pattern, + ;; since it is not nullable. + (cons rng-empty-ipattern + (if (eq (rng-ipattern-get-type ipattern) 'choice) + (rng-ipattern-get-child ipattern) + (list ipattern))) + t)))) + + +(defun rng-intern-choice1 (normalized nullable) + (let ((key (cons 'choice + (mapcar 'rng-ipattern-get-index normalized)))) + (or (rng-get-ipattern key) + (rng-put-ipattern key + 'choice + nil + normalized + nullable)))) + +(defun rng-intern-choice-shortcut (ipatterns) + "Try to shortcut interning a choice list. If successful, return the +interned pattern. Otherwise return nil." + (while (and ipatterns + (eq (car ipatterns) + rng-not-allowed-ipattern)) + (setq ipatterns (cdr ipatterns))) + (if ipatterns + (let ((ret (car ipatterns))) + (setq ipatterns (cdr ipatterns)) + (while (and ipatterns ret) + (or (eq (car ipatterns) rng-not-allowed-ipattern) + (eq (car ipatterns) ret) + (setq ret nil)) + (setq ipatterns (cdr ipatterns))) + ret) + rng-not-allowed-ipattern)) + +(defun rng-normalize-choice-list (ipatterns) + "Normalize a list of choices, expanding nested choices, removing +not-allowed members, sorting by index and removing duplicates. Return +a pair whose car says whether the list is nullable and whose cdr is +the normalized list." + (let ((sorted t) + (nullable nil) + (head (cons nil ipatterns))) + (let ((tail head) + (final-tail nil) + (prev-index -100) + (cur ipatterns) + member) + ;; the cdr of tail is always cur + (while cur + (setq member (car cur)) + (or nullable + (setq nullable (rng-ipattern-get-nullable member))) + (cond ((eq (rng-ipattern-get-type member) 'choice) + (setq final-tail + (append (rng-ipattern-get-child member) + final-tail)) + (setq cur (cdr cur)) + (setq sorted nil) + (setcdr tail cur)) + ((eq member rng-not-allowed-ipattern) + (setq cur (cdr cur)) + (setcdr tail cur)) + (t + (if (and sorted + (let ((cur-index (rng-ipattern-get-index member))) + (if (>= prev-index cur-index) + (or (= prev-index cur-index) ; will remove it + (setq sorted nil)) ; won't remove it + (setq prev-index cur-index) + ;; won't remove it + nil))) + (progn + ;; remove it + (setq cur (cdr cur)) + (setcdr tail cur)) + ;; don't remove it + (setq tail cur) + (setq cur (cdr cur)))))) + (setcdr tail final-tail)) + (setq head (cdr head)) + (cons nullable + (if sorted + head + (rng-uniquify-eq (sort head 'rng-compare-ipattern)))))) + +(defun rng-compare-ipattern (p1 p2) + (< (rng-ipattern-get-index p1) + (rng-ipattern-get-index p2))) + +;;; Name classes + +(defsubst rng-name-class-contains (nc nm) + (if (consp nc) + (equal nm nc) + (rng-name-class-contains1 nc nm))) + +(defun rng-name-class-contains1 (nc nm) + (let ((type (aref nc 0))) + (cond ((eq type 'any-name) t) + ((eq type 'any-name-except) + (not (rng-name-class-contains (aref nc 1) nm))) + ((eq type 'ns-name) + (eq (car nm) (aref nc 1))) + ((eq type 'ns-name-except) + (and (eq (car nm) (aref nc 1)) + (not (rng-name-class-contains (aref nc 2) nm)))) + ((eq type 'choice) + (let ((choices (aref nc 1)) + (ret nil)) + (while choices + (if (rng-name-class-contains (car choices) nm) + (progn + (setq choices nil) + (setq ret t)) + (setq choices (cdr choices)))) + ret))))) + +(defun rng-name-class-possible-names (nc accum) + "Return a list of possible names that nameclass NC can match. + +Each possible name should be returned as a (NAMESPACE . LOCAL-NAME) +pair, where NAMESPACE is a symbol or nil and LOCAL-NAME is a string. +nil for NAMESPACE matches the absent namespace. ACCUM is a list of +names which should be appended to the returned list. The returned list +may contain duplicates." + (if (consp nc) + (cons nc accum) + (when (eq (aref nc 0) 'choice) + (let ((members (aref nc 1)) member) + (while members + (setq member (car members)) + (setq accum + (if (consp member) + (cons member accum) + (rng-name-class-possible-names member + accum))) + (setq members (cdr members))))) + accum)) + +;;; Debugging utilities + +(defun rng-ipattern-to-string (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (concat (rng-ipattern-to-string + (rng-ipattern-get-child ipattern)) + " </> " + (rng-ipattern-to-string + (rng-ipattern-get-after ipattern)))) + ((eq type 'element) + (concat "element " + (rng-name-class-to-string + (rng-ipattern-get-name-class ipattern)) + ;; we can get cycles with elements so don't print it out + " {...}")) + ((eq type 'attribute) + (concat "attribute " + (rng-name-class-to-string + (rng-ipattern-get-name-class ipattern)) + " { " + (rng-ipattern-to-string + (rng-ipattern-get-child ipattern)) + " } ")) + ((eq type 'empty) "empty") + ((eq type 'text) "text") + ((eq type 'not-allowed) "notAllowed") + ((eq type 'one-or-more) + (concat (rng-ipattern-to-string + (rng-ipattern-get-child ipattern)) + "+")) + ((eq type 'choice) + (concat "(" + (mapconcat 'rng-ipattern-to-string + (rng-ipattern-get-child ipattern) + " | ") + ")")) + ((eq type 'group) + (concat "(" + (mapconcat 'rng-ipattern-to-string + (rng-ipattern-get-child ipattern) + ", ") + ")")) + ((eq type 'interleave) + (concat "(" + (mapconcat 'rng-ipattern-to-string + (rng-ipattern-get-child ipattern) + " & ") + ")")) + (t (symbol-name type))))) + +(defun rng-name-class-to-string (nc) + (if (consp nc) + (cdr nc) + (let ((type (aref nc 0))) + (cond ((eq type 'choice) + (mapconcat 'rng-name-class-to-string + (aref nc 1) + "|")) + (t (concat (symbol-name type) "*")))))) + + +;;; Compiling + +(defun rng-compile-maybe-init () + (unless rng-compile-table + (setq rng-compile-table (make-hash-table :test 'eq)))) + +(defun rng-compile-clear () + (when rng-compile-table + (clrhash rng-compile-table))) + +(defun rng-compile (pattern) + (or (gethash pattern rng-compile-table) + (let ((ipattern (apply (get (car pattern) 'rng-compile) + (cdr pattern)))) + (puthash pattern ipattern rng-compile-table) + ipattern))) + +(put 'empty 'rng-compile 'rng-compile-empty) +(put 'text 'rng-compile 'rng-compile-text) +(put 'not-allowed 'rng-compile 'rng-compile-not-allowed) +(put 'element 'rng-compile 'rng-compile-element) +(put 'attribute 'rng-compile 'rng-compile-attribute) +(put 'choice 'rng-compile 'rng-compile-choice) +(put 'optional 'rng-compile 'rng-compile-optional) +(put 'group 'rng-compile 'rng-compile-group) +(put 'interleave 'rng-compile 'rng-compile-interleave) +(put 'ref 'rng-compile 'rng-compile-ref) +(put 'one-or-more 'rng-compile 'rng-compile-one-or-more) +(put 'zero-or-more 'rng-compile 'rng-compile-zero-or-more) +(put 'mixed 'rng-compile 'rng-compile-mixed) +(put 'data 'rng-compile 'rng-compile-data) +(put 'data-except 'rng-compile 'rng-compile-data-except) +(put 'value 'rng-compile 'rng-compile-value) +(put 'list 'rng-compile 'rng-compile-list) + +(defun rng-compile-not-allowed () rng-not-allowed-ipattern) +(defun rng-compile-empty () rng-empty-ipattern) +(defun rng-compile-text () rng-text-ipattern) + +(defun rng-compile-element (name-class pattern) + ;; don't intern + (rng-make-ipattern 'element + (rng-gen-ipattern-index) + (rng-compile-name-class name-class) + pattern ; compile lazily + nil)) + +(defun rng-element-get-child (element) + (let ((tem (rng-ipattern-get-child element))) + (if (vectorp tem) + tem + (rng-ipattern-set-child element (rng-compile tem))))) + +(defun rng-compile-attribute (name-class pattern) + (rng-intern-attribute (rng-compile-name-class name-class) + (rng-compile pattern))) + +(defun rng-compile-ref (pattern name) + (and (memq pattern rng-being-compiled) + (rng-compile-error "Reference loop on symbol %s" name)) + (setq rng-being-compiled + (cons pattern rng-being-compiled)) + (unwind-protect + (rng-compile pattern) + (setq rng-being-compiled + (cdr rng-being-compiled)))) + +(defun rng-compile-one-or-more (pattern) + (rng-intern-one-or-more (rng-compile pattern))) + +(defun rng-compile-zero-or-more (pattern) + (rng-intern-optional + (rng-intern-one-or-more (rng-compile pattern)))) + +(defun rng-compile-optional (pattern) + (rng-intern-optional (rng-compile pattern))) + +(defun rng-compile-mixed (pattern) + (rng-intern-interleave (cons rng-text-ipattern + (list (rng-compile pattern))))) + +(defun rng-compile-list (pattern) + (rng-intern-list (rng-compile pattern))) + +(defun rng-compile-choice (&rest patterns) + (rng-intern-choice (mapcar 'rng-compile patterns))) + +(defun rng-compile-group (&rest patterns) + (rng-intern-group (mapcar 'rng-compile patterns))) + +(defun rng-compile-interleave (&rest patterns) + (rng-intern-interleave (mapcar 'rng-compile patterns))) + +(defun rng-compile-dt (name params) + (let ((rng-dt-error-reporter 'rng-compile-error)) + (funcall (let ((uri (car name))) + (or (get uri 'rng-dt-compile) + (rng-compile-error "Unknown datatype library %s" uri))) + (cdr name) + params))) + +(defun rng-compile-data (name params) + (let ((dt (rng-compile-dt name params))) + (rng-intern-data (cdr dt) (car dt)))) + +(defun rng-compile-data-except (name params pattern) + (rng-intern-data-except (cdr (rng-compile-dt name params)) + (rng-compile pattern))) + +(defun rng-compile-value (name str context) + (let* ((dt (cdr (rng-compile-dt name '()))) + (rng-dt-namespace-context-getter (list 'identity context)) + (obj (rng-dt-make-value dt str))) + (if obj + (rng-intern-value dt obj) + (rng-compile-error "Value %s is not a valid instance of the datatype %s" + str + name)))) + +(defun rng-compile-name-class (nc) + (let ((type (car nc))) + (cond ((eq type 'name) (nth 1 nc)) + ((eq type 'any-name) [any-name]) + ((eq type 'any-name-except) + (vector 'any-name-except + (rng-compile-name-class (nth 1 nc)))) + ((eq type 'ns-name) + (vector 'ns-name (nth 1 nc))) + ((eq type 'ns-name-except) + (vector 'ns-name-except + (nth 1 nc) + (rng-compile-name-class (nth 2 nc)))) + ((eq type 'choice) + (vector 'choice + (mapcar 'rng-compile-name-class (cdr nc)))) + (t (error "Bad name-class type %s" type))))) + +;;; Searching patterns + +;; We write this non-recursively to avoid hitting max-lisp-eval-depth +;; on large schemas. + +(defun rng-map-element-attribute (function pattern accum &rest args) + (let ((searched (make-hash-table :test 'eq)) + type todo patterns) + (while (progn + (setq type (car pattern)) + (cond ((memq type '(element attribute)) + (setq accum + (apply function + (cons pattern + (cons accum args)))) + (setq pattern (nth 2 pattern))) + ((eq type 'ref) + (setq pattern (nth 1 pattern)) + (if (gethash pattern searched) + (setq pattern nil) + (puthash pattern t searched))) + ((memq type '(choice group interleave)) + (setq todo (cons (cdr pattern) todo)) + (setq pattern nil)) + ((memq type '(one-or-more + zero-or-more + optional + mixed)) + (setq pattern (nth 1 pattern))) + (t (setq pattern nil))) + (cond (pattern) + (patterns + (setq pattern (car patterns)) + (setq patterns (cdr patterns)) + t) + (todo + (setq patterns (car todo)) + (setq todo (cdr todo)) + (setq pattern (car patterns)) + (setq patterns (cdr patterns)) + t)))) + accum)) + +(defun rng-find-element-content-pattern (pattern accum name) + (if (and (eq (car pattern) 'element) + (rng-search-name name (nth 1 pattern))) + (cons (rng-compile (nth 2 pattern)) accum) + accum)) + +(defun rng-search-name (name nc) + (let ((type (car nc))) + (cond ((eq type 'name) + (equal (cadr nc) name)) + ((eq type 'choice) + (let ((choices (cdr nc)) + (found nil)) + (while (and choices (not found)) + (if (rng-search-name name (car choices)) + (setq found t) + (setq choices (cdr choices)))) + found)) + (t nil)))) + +(defun rng-find-name-class-uris (nc accum) + (let ((type (car nc))) + (cond ((eq type 'name) + (rng-accum-namespace-uri (car (nth 1 nc)) accum)) + ((memq type '(ns-name ns-name-except)) + (rng-accum-namespace-uri (nth 1 nc) accum)) + ((eq type 'choice) + (let ((choices (cdr nc))) + (while choices + (setq accum + (rng-find-name-class-uris (car choices) accum)) + (setq choices (cdr choices)))) + accum) + (t accum)))) + +(defun rng-accum-namespace-uri (ns accum) + (if (and ns (not (memq ns accum))) + (cons ns accum) + accum)) + +;;; Derivatives + +(defun rng-ipattern-text-typed-p (ipattern) + (let ((memo (rng-ipattern-get-memo-text-typed ipattern))) + (if (eq memo 'unknown) + (rng-ipattern-set-memo-text-typed + ipattern + (rng-ipattern-compute-text-typed-p ipattern)) + memo))) + +(defun rng-ipattern-compute-text-typed-p (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'choice) + (let ((cur (rng-ipattern-get-child ipattern)) + (ret nil)) + (while (and cur (not ret)) + (if (rng-ipattern-text-typed-p (car cur)) + (setq ret t) + (setq cur (cdr cur)))) + ret)) + ((eq type 'group) + (let ((cur (rng-ipattern-get-child ipattern)) + (ret nil) + member) + (while (and cur (not ret)) + (setq member (car cur)) + (if (rng-ipattern-text-typed-p member) + (setq ret t)) + (setq cur + (and (rng-ipattern-get-nullable member) + (cdr cur)))) + ret)) + ((eq type 'after) + (rng-ipattern-text-typed-p (rng-ipattern-get-child ipattern))) + (t (and (memq type '(value list data data-except)) t))))) + +(defun rng-start-tag-open-deriv (ipattern nm) + (or (rng-memo-map-get + nm + (rng-ipattern-get-memo-map-start-tag-open-deriv ipattern)) + (rng-ipattern-memo-start-tag-open-deriv + ipattern + nm + (rng-compute-start-tag-open-deriv ipattern nm)))) + +(defun rng-ipattern-memo-start-tag-open-deriv (ipattern nm deriv) + (or (memq ipattern rng-const-ipatterns) + (rng-ipattern-set-memo-map-start-tag-open-deriv + ipattern + (rng-memo-map-add nm + deriv + (rng-ipattern-get-memo-map-start-tag-open-deriv + ipattern)))) + deriv) + +(defun rng-compute-start-tag-open-deriv (ipattern nm) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'choice) + (rng-transform-choice `(lambda (p) + (rng-start-tag-open-deriv p ',nm)) + ipattern)) + ((eq type 'element) + (if (rng-name-class-contains + (rng-ipattern-get-name-class ipattern) + nm) + (rng-intern-after (rng-element-get-child ipattern) + rng-empty-ipattern) + rng-not-allowed-ipattern)) + ((eq type 'group) + (rng-transform-group-nullable + `(lambda (p) (rng-start-tag-open-deriv p ',nm)) + 'rng-cons-group-after + ipattern)) + ((eq type 'interleave) + (rng-transform-interleave-single + `(lambda (p) (rng-start-tag-open-deriv p ',nm)) + 'rng-subst-interleave-after + ipattern)) + ((eq type 'one-or-more) + (rng-apply-after + `(lambda (p) + (rng-intern-group (list p ,(rng-intern-optional ipattern)))) + (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern) + nm))) + ((eq type 'after) + (rng-apply-after + `(lambda (p) + (rng-intern-after p + ,(rng-ipattern-get-after ipattern))) + (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern) + nm))) + (t rng-not-allowed-ipattern)))) + +(defun rng-start-attribute-deriv (ipattern nm) + (or (rng-memo-map-get + nm + (rng-ipattern-get-memo-map-start-attribute-deriv ipattern)) + (rng-ipattern-memo-start-attribute-deriv + ipattern + nm + (rng-compute-start-attribute-deriv ipattern nm)))) + +(defun rng-ipattern-memo-start-attribute-deriv (ipattern nm deriv) + (or (memq ipattern rng-const-ipatterns) + (rng-ipattern-set-memo-map-start-attribute-deriv + ipattern + (rng-memo-map-add + nm + deriv + (rng-ipattern-get-memo-map-start-attribute-deriv ipattern)))) + deriv) + +(defun rng-compute-start-attribute-deriv (ipattern nm) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'choice) + (rng-transform-choice `(lambda (p) + (rng-start-attribute-deriv p ',nm)) + ipattern)) + ((eq type 'attribute) + (if (rng-name-class-contains + (rng-ipattern-get-name-class ipattern) + nm) + (rng-intern-after (rng-ipattern-get-child ipattern) + rng-empty-ipattern) + rng-not-allowed-ipattern)) + ((eq type 'group) + (rng-transform-interleave-single + `(lambda (p) (rng-start-attribute-deriv p ',nm)) + 'rng-subst-group-after + ipattern)) + ((eq type 'interleave) + (rng-transform-interleave-single + `(lambda (p) (rng-start-attribute-deriv p ',nm)) + 'rng-subst-interleave-after + ipattern)) + ((eq type 'one-or-more) + (rng-apply-after + `(lambda (p) + (rng-intern-group (list p ,(rng-intern-optional ipattern)))) + (rng-start-attribute-deriv (rng-ipattern-get-child ipattern) + nm))) + ((eq type 'after) + (rng-apply-after + `(lambda (p) + (rng-intern-after p ,(rng-ipattern-get-after ipattern))) + (rng-start-attribute-deriv (rng-ipattern-get-child ipattern) + nm))) + (t rng-not-allowed-ipattern)))) + +(defun rng-cons-group-after (x y) + (rng-apply-after `(lambda (p) (rng-intern-group (cons p ',y))) + x)) + +(defun rng-subst-group-after (new old list) + (rng-apply-after `(lambda (p) + (rng-intern-group (rng-substq p ,old ',list))) + new)) + +(defun rng-subst-interleave-after (new old list) + (rng-apply-after `(lambda (p) + (rng-intern-interleave (rng-substq p ,old ',list))) + new)) + +(defun rng-apply-after (f ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (rng-intern-after + (rng-ipattern-get-child ipattern) + (funcall f + (rng-ipattern-get-after ipattern)))) + ((eq type 'choice) + (rng-transform-choice `(lambda (x) (rng-apply-after ,f x)) + ipattern)) + (t rng-not-allowed-ipattern)))) + +(defun rng-start-tag-close-deriv (ipattern) + (or (rng-ipattern-get-memo-start-tag-close-deriv ipattern) + (rng-ipattern-set-memo-start-tag-close-deriv + ipattern + (rng-compute-start-tag-close-deriv ipattern)))) + +(defconst rng-transform-map + '((choice . rng-transform-choice) + (group . rng-transform-group) + (interleave . rng-transform-interleave) + (one-or-more . rng-transform-one-or-more) + (after . rng-transform-after-child))) + +(defun rng-compute-start-tag-close-deriv (ipattern) + (let* ((type (rng-ipattern-get-type ipattern))) + (if (eq type 'attribute) + rng-not-allowed-ipattern + (let ((transform (assq type rng-transform-map))) + (if transform + (funcall (cdr transform) + 'rng-start-tag-close-deriv + ipattern) + ipattern))))) + +(defun rng-ignore-attributes-deriv (ipattern) + (let* ((type (rng-ipattern-get-type ipattern))) + (if (eq type 'attribute) + rng-empty-ipattern + (let ((transform (assq type rng-transform-map))) + (if transform + (funcall (cdr transform) + 'rng-ignore-attributes-deriv + ipattern) + ipattern))))) + +(defun rng-text-only-deriv (ipattern) + (or (rng-ipattern-get-memo-text-only-deriv ipattern) + (rng-ipattern-set-memo-text-only-deriv + ipattern + (rng-compute-text-only-deriv ipattern)))) + +(defun rng-compute-text-only-deriv (ipattern) + (let* ((type (rng-ipattern-get-type ipattern))) + (if (eq type 'element) + rng-not-allowed-ipattern + (let ((transform (assq type + '((choice . rng-transform-choice) + (group . rng-transform-group) + (interleave . rng-transform-interleave) + (one-or-more . rng-transform-one-or-more) + (after . rng-transform-after-child))))) + (if transform + (funcall (cdr transform) + 'rng-text-only-deriv + ipattern) + ipattern))))) + +(defun rng-mixed-text-deriv (ipattern) + (or (rng-ipattern-get-memo-mixed-text-deriv ipattern) + (rng-ipattern-set-memo-mixed-text-deriv + ipattern + (rng-compute-mixed-text-deriv ipattern)))) + +(defun rng-compute-mixed-text-deriv (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'text) ipattern) + ((eq type 'after) + (rng-transform-after-child 'rng-mixed-text-deriv + ipattern)) + ((eq type 'choice) + (rng-transform-choice 'rng-mixed-text-deriv + ipattern)) + ((eq type 'one-or-more) + (rng-intern-group + (list (rng-mixed-text-deriv + (rng-ipattern-get-child ipattern)) + (rng-intern-optional ipattern)))) + ((eq type 'group) + (rng-transform-group-nullable + 'rng-mixed-text-deriv + (lambda (x y) (rng-intern-group (cons x y))) + ipattern)) + ((eq type 'interleave) + (rng-transform-interleave-single + 'rng-mixed-text-deriv + (lambda (new old list) (rng-intern-interleave + (rng-substq new old list))) + ipattern)) + ((and (eq type 'data) + (not (rng-ipattern-get-memo-text-typed ipattern))) + ipattern) + (t rng-not-allowed-ipattern)))) + +(defun rng-end-tag-deriv (ipattern) + (or (rng-ipattern-get-memo-end-tag-deriv ipattern) + (rng-ipattern-set-memo-end-tag-deriv + ipattern + (rng-compute-end-tag-deriv ipattern)))) + +(defun rng-compute-end-tag-deriv (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'choice) + (rng-intern-choice + (mapcar 'rng-end-tag-deriv + (rng-ipattern-get-child ipattern)))) + ((eq type 'after) + (if (rng-ipattern-get-nullable + (rng-ipattern-get-child ipattern)) + (rng-ipattern-get-after ipattern) + rng-not-allowed-ipattern)) + (t rng-not-allowed-ipattern)))) + +(defun rng-data-deriv (ipattern value) + (or (rng-memo-map-get value + (rng-ipattern-get-memo-map-data-deriv ipattern)) + (and (rng-memo-map-get + (cons value (rng-namespace-context-get-no-trace)) + (rng-ipattern-get-memo-map-data-deriv ipattern)) + (rng-memo-map-get + (cons value (apply (car rng-dt-namespace-context-getter) + (cdr rng-dt-namespace-context-getter))) + (rng-ipattern-get-memo-map-data-deriv ipattern))) + (let* ((used-context (vector nil)) + (rng-dt-namespace-context-getter + (cons 'rng-namespace-context-tracer + (cons used-context + rng-dt-namespace-context-getter))) + (deriv (rng-compute-data-deriv ipattern value))) + (rng-ipattern-memo-data-deriv ipattern + value + (aref used-context 0) + deriv)))) + +(defun rng-namespace-context-tracer (used getter &rest args) + (let ((context (apply getter args))) + (aset used 0 context) + context)) + +(defun rng-namespace-context-get-no-trace () + (let ((tem rng-dt-namespace-context-getter)) + (while (and tem (eq (car tem) 'rng-namespace-context-tracer)) + (setq tem (cddr tem))) + (apply (car tem) (cdr tem)))) + +(defconst rng-memo-data-deriv-max-length 80 + "Don't memoize data-derivs for values longer than this.") + +(defun rng-ipattern-memo-data-deriv (ipattern value context deriv) + (or (memq ipattern rng-const-ipatterns) + (> (length value) rng-memo-data-deriv-max-length) + (rng-ipattern-set-memo-map-data-deriv + ipattern + (rng-memo-map-add (if context (cons value context) value) + deriv + (rng-ipattern-get-memo-map-data-deriv ipattern) + t))) + deriv) + +(defun rng-compute-data-deriv (ipattern value) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'text) ipattern) + ((eq type 'choice) + (rng-transform-choice `(lambda (p) (rng-data-deriv p ,value)) + ipattern)) + ((eq type 'group) + (rng-transform-group-nullable + `(lambda (p) (rng-data-deriv p ,value)) + (lambda (x y) (rng-intern-group (cons x y))) + ipattern)) + ((eq type 'one-or-more) + (rng-intern-group (list (rng-data-deriv + (rng-ipattern-get-child ipattern) + value) + (rng-intern-optional ipattern)))) + ((eq type 'after) + (let ((child (rng-ipattern-get-child ipattern))) + (if (or (rng-ipattern-get-nullable + (rng-data-deriv child value)) + (and (rng-ipattern-get-nullable child) + (rng-blank-p value))) + (rng-ipattern-get-after ipattern) + rng-not-allowed-ipattern))) + ((eq type 'data) + (if (rng-dt-make-value (rng-ipattern-get-datatype ipattern) + value) + rng-empty-ipattern + rng-not-allowed-ipattern)) + ((eq type 'data-except) + (if (and (rng-dt-make-value (rng-ipattern-get-datatype ipattern) + value) + (not (rng-ipattern-get-nullable + (rng-data-deriv + (rng-ipattern-get-child ipattern) + value)))) + rng-empty-ipattern + rng-not-allowed-ipattern)) + ((eq type 'value) + (if (equal (rng-dt-make-value (rng-ipattern-get-datatype ipattern) + value) + (rng-ipattern-get-value-object ipattern)) + rng-empty-ipattern + rng-not-allowed-ipattern)) + ((eq type 'list) + (let ((tokens (split-string value)) + (state (rng-ipattern-get-child ipattern))) + (while (and tokens + (not (eq state rng-not-allowed-ipattern))) + (setq state (rng-data-deriv state (car tokens))) + (setq tokens (cdr tokens))) + (if (rng-ipattern-get-nullable state) + rng-empty-ipattern + rng-not-allowed-ipattern))) + ;; don't think interleave can occur + ;; since we do text-only-deriv first + (t rng-not-allowed-ipattern)))) + +(defun rng-transform-multi (f ipattern interner) + (let* ((members (rng-ipattern-get-child ipattern)) + (transformed (mapcar f members))) + (if (rng-members-eq members transformed) + ipattern + (funcall interner transformed)))) + +(defun rng-transform-choice (f ipattern) + (rng-transform-multi f ipattern 'rng-intern-choice)) + +(defun rng-transform-group (f ipattern) + (rng-transform-multi f ipattern 'rng-intern-group)) + +(defun rng-transform-interleave (f ipattern) + (rng-transform-multi f ipattern 'rng-intern-interleave)) + +(defun rng-transform-one-or-more (f ipattern) + (let* ((child (rng-ipattern-get-child ipattern)) + (transformed (funcall f child))) + (if (eq child transformed) + ipattern + (rng-intern-one-or-more transformed)))) + +(defun rng-transform-after-child (f ipattern) + (let* ((child (rng-ipattern-get-child ipattern)) + (transformed (funcall f child))) + (if (eq child transformed) + ipattern + (rng-intern-after transformed + (rng-ipattern-get-after ipattern))))) + +(defun rng-transform-interleave-single (f subster ipattern) + (let ((children (rng-ipattern-get-child ipattern)) + found) + (while (and children (not found)) + (let* ((child (car children)) + (transformed (funcall f child))) + (if (eq transformed rng-not-allowed-ipattern) + (setq children (cdr children)) + (setq found + (funcall subster + transformed + child + (rng-ipattern-get-child ipattern)))))) + (or found + rng-not-allowed-ipattern))) + +(defun rng-transform-group-nullable (f conser ipattern) + "Given a group x1,...,xn,y1,...,yn where the xs are all +nullable and y1 isn't, return a choice + (conser f(x1) x2,...,xm,y1,...,yn) + |(conser f(x2) x3,...,xm,y1,...,yn) + |... + |(conser f(xm) y1,...,yn) + |(conser f(y1) y2,...,yn)" + (rng-intern-choice + (rng-transform-group-nullable-gen-choices + f + conser + (rng-ipattern-get-child ipattern)))) + +(defun rng-transform-group-nullable-gen-choices (f conser members) + (let ((head (car members)) + (tail (cdr members))) + (if tail + (cons (funcall conser (funcall f head) tail) + (if (rng-ipattern-get-nullable head) + (rng-transform-group-nullable-gen-choices f conser tail) + nil)) + (list (funcall f head))))) + +(defun rng-members-eq (list1 list2) + (while (and list1 + list2 + (eq (car list1) (car list2))) + (setq list1 (cdr list1)) + (setq list2 (cdr list2))) + (and (null list1) (null list2))) + + +(defun rng-ipattern-after (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'choice) + (rng-transform-choice 'rng-ipattern-after ipattern)) + ((eq type 'after) + (rng-ipattern-get-after ipattern)) + ((eq type 'not-allowed) + ipattern) + (t (error "Internal error in rng-ipattern-after: unexpected type %s" type))))) + +(defun rng-unknown-start-tag-open-deriv (ipattern) + (rng-intern-after (rng-compile rng-any-content) ipattern)) + +(defun rng-ipattern-optionalize-elements (ipattern) + (let* ((type (rng-ipattern-get-type ipattern)) + (transform (assq type rng-transform-map))) + (cond (transform + (funcall (cdr transform) + 'rng-ipattern-optionalize-elements + ipattern)) + ((eq type 'element) + (rng-intern-optional ipattern)) + (t ipattern)))) + +(defun rng-ipattern-empty-before-p (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (eq (rng-ipattern-get-child ipattern) rng-empty-ipattern)) + ((eq type 'choice) + (let ((members (rng-ipattern-get-child ipattern)) + (ret t)) + (while (and members ret) + (or (rng-ipattern-empty-before-p (car members)) + (setq ret nil)) + (setq members (cdr members))) + ret)) + (t nil)))) + +(defun rng-ipattern-possible-start-tags (ipattern accum) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (rng-ipattern-possible-start-tags + (rng-ipattern-get-child ipattern) + accum)) + ((memq type '(choice interleave)) + (let ((members (rng-ipattern-get-child ipattern))) + (while members + (setq accum + (rng-ipattern-possible-start-tags (car members) + accum)) + (setq members (cdr members)))) + accum) + ((eq type 'group) + (let ((members (rng-ipattern-get-child ipattern))) + (while members + (setq accum + (rng-ipattern-possible-start-tags (car members) + accum)) + (setq members + (and (rng-ipattern-get-nullable (car members)) + (cdr members))))) + accum) + ((eq type 'element) + (if (eq (rng-element-get-child ipattern) rng-not-allowed-ipattern) + accum + (rng-name-class-possible-names + (rng-ipattern-get-name-class ipattern) + accum))) + ((eq type 'one-or-more) + (rng-ipattern-possible-start-tags + (rng-ipattern-get-child ipattern) + accum)) + (t accum)))) + +(defun rng-ipattern-start-tag-possible-p (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((memq type '(after one-or-more)) + (rng-ipattern-start-tag-possible-p + (rng-ipattern-get-child ipattern))) + ((memq type '(choice interleave)) + (let ((members (rng-ipattern-get-child ipattern)) + (possible nil)) + (while (and members (not possible)) + (setq possible + (rng-ipattern-start-tag-possible-p (car members))) + (setq members (cdr members))) + possible)) + ((eq type 'group) + (let ((members (rng-ipattern-get-child ipattern)) + (possible nil)) + (while (and members (not possible)) + (setq possible + (rng-ipattern-start-tag-possible-p (car members))) + (setq members + (and (rng-ipattern-get-nullable (car members)) + (cdr members)))) + possible)) + ((eq type 'element) + (not (eq (rng-element-get-child ipattern) + rng-not-allowed-ipattern))) + (t nil)))) + +(defun rng-ipattern-possible-attributes (ipattern accum) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (rng-ipattern-possible-attributes (rng-ipattern-get-child ipattern) + accum)) + ((memq type '(choice interleave group)) + (let ((members (rng-ipattern-get-child ipattern))) + (while members + (setq accum + (rng-ipattern-possible-attributes (car members) + accum)) + (setq members (cdr members)))) + accum) + ((eq type 'attribute) + (rng-name-class-possible-names + (rng-ipattern-get-name-class ipattern) + accum)) + ((eq type 'one-or-more) + (rng-ipattern-possible-attributes + (rng-ipattern-get-child ipattern) + accum)) + (t accum)))) + +(defun rng-ipattern-possible-values (ipattern accum) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (rng-ipattern-possible-values (rng-ipattern-get-child ipattern) + accum)) + ((eq type 'choice) + (let ((members (rng-ipattern-get-child ipattern))) + (while members + (setq accum + (rng-ipattern-possible-values (car members) + accum)) + (setq members (cdr members)))) + accum) + ((eq type 'value) + (let ((value-object (rng-ipattern-get-value-object ipattern))) + (if (stringp value-object) + (cons value-object accum) + accum))) + (t accum)))) + +(defun rng-ipattern-required-element (ipattern) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((memq type '(after one-or-more)) + (rng-ipattern-required-element (rng-ipattern-get-child ipattern))) + ((eq type 'choice) + (let* ((members (rng-ipattern-get-child ipattern)) + (required (rng-ipattern-required-element (car members)))) + (while (and required + (setq members (cdr members))) + (unless (equal required + (rng-ipattern-required-element (car members))) + (setq required nil))) + required)) + ((eq type 'group) + (let ((members (rng-ipattern-get-child ipattern)) + required) + (while (and (not (setq required + (rng-ipattern-required-element + (car members)))) + (rng-ipattern-get-nullable (car members)) + (setq members (cdr members)))) + required)) + ((eq type 'interleave) + (let ((members (rng-ipattern-get-child ipattern)) + required) + (while members + (let ((tem (rng-ipattern-required-element (car members)))) + (cond ((not tem) + (setq members (cdr members))) + ((not required) + (setq required tem) + (setq members (cdr members))) + ((equal required tem) + (setq members (cdr members))) + (t + (setq required nil) + (setq members nil))))) + required)) + ((eq type 'element) + (let ((nc (rng-ipattern-get-name-class ipattern))) + (and (consp nc) + (not (eq (rng-element-get-child ipattern) + rng-not-allowed-ipattern)) + nc)))))) + +(defun rng-ipattern-required-attributes (ipattern accum) + (let ((type (rng-ipattern-get-type ipattern))) + (cond ((eq type 'after) + (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern) + accum)) + ((memq type '(interleave group)) + (let ((members (rng-ipattern-get-child ipattern))) + (while members + (setq accum + (rng-ipattern-required-attributes (car members) + accum)) + (setq members (cdr members)))) + accum) + ((eq type 'choice) + (let ((members (rng-ipattern-get-child ipattern)) + in-all in-this new-in-all) + (setq in-all + (rng-ipattern-required-attributes (car members) + nil)) + (while (and in-all (setq members (cdr members))) + (setq in-this + (rng-ipattern-required-attributes (car members) nil)) + (setq new-in-all nil) + (while in-this + (when (member (car in-this) in-all) + (setq new-in-all + (cons (car in-this) new-in-all))) + (setq in-this (cdr in-this))) + (setq in-all new-in-all)) + (append in-all accum))) + ((eq type 'attribute) + (let ((nc (rng-ipattern-get-name-class ipattern))) + (if (consp nc) + (cons nc accum) + accum))) + ((eq type 'one-or-more) + (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern) + accum)) + (t accum)))) + +(defun rng-compile-error (&rest args) + (signal 'rng-compile-error + (list (apply 'format args)))) + +(put 'rng-compile-error + 'error-conditions + '(error rng-error rng-compile-error)) + +(put 'rng-compile-error + 'error-message + "Incorrect schema") + + +;;; External API + +(defsubst rng-match-state () rng-match-state) + +(defsubst rng-set-match-state (state) + (setq rng-match-state state)) + +(defsubst rng-match-state-equal (state) + (eq state rng-match-state)) + +(defun rng-schema-changed () + (rng-ipattern-clear) + (rng-compile-clear)) + +(defun rng-match-init-buffer () + (make-local-variable 'rng-compile-table) + (make-local-variable 'rng-ipattern-table) + (make-local-variable 'rng-last-ipattern-index)) + +(defun rng-match-start-document () + (rng-ipattern-maybe-init) + (rng-compile-maybe-init) + (add-hook 'rng-schema-change-hook 'rng-schema-changed nil t) + (setq rng-match-state (rng-compile rng-current-schema))) + +(defun rng-match-start-tag-open (name) + (rng-update-match-state (rng-start-tag-open-deriv rng-match-state + name))) + +(defun rng-match-attribute-name (name) + (rng-update-match-state (rng-start-attribute-deriv rng-match-state + name))) + +(defun rng-match-attribute-value (value) + (rng-update-match-state (rng-data-deriv rng-match-state + value))) + +(defun rng-match-element-value (value) + (and (rng-update-match-state (rng-text-only-deriv rng-match-state)) + (rng-update-match-state (rng-data-deriv rng-match-state + value)))) + +(defun rng-match-start-tag-close () + (rng-update-match-state (rng-start-tag-close-deriv rng-match-state))) + +(defun rng-match-mixed-text () + (rng-update-match-state (rng-mixed-text-deriv rng-match-state))) + +(defun rng-match-end-tag () + (rng-update-match-state (rng-end-tag-deriv rng-match-state))) + +(defun rng-match-after () + (rng-update-match-state + (rng-ipattern-after rng-match-state))) + +(defun rng-match-out-of-context-start-tag-open (name) + (let* ((found (rng-map-element-attribute 'rng-find-element-content-pattern + rng-current-schema + nil + name)) + (content-pattern (if found + (rng-intern-choice found) + rng-not-allowed-ipattern))) + (rng-update-match-state + (rng-intern-after content-pattern rng-match-state)))) + +(defun rng-match-possible-namespace-uris () + "Return a list of all the namespace URIs used in the current schema. +The absent URI is not included, so the result is always list of symbols." + (rng-map-element-attribute (lambda (pattern accum) + (rng-find-name-class-uris (nth 1 pattern) + accum)) + rng-current-schema + nil)) + +(defun rng-match-unknown-start-tag-open () + (rng-update-match-state + (rng-unknown-start-tag-open-deriv rng-match-state))) + +(defun rng-match-optionalize-elements () + (rng-update-match-state + (rng-ipattern-optionalize-elements rng-match-state))) + +(defun rng-match-ignore-attributes () + (rng-update-match-state + (rng-ignore-attributes-deriv rng-match-state))) + +(defun rng-match-text-typed-p () + (rng-ipattern-text-typed-p rng-match-state)) + +(defun rng-match-empty-content () + (if (rng-match-text-typed-p) + (rng-match-element-value "") + (rng-match-end-tag))) + +(defun rng-match-empty-before-p () + "Return non-nil if what can be matched before an end-tag is empty. +In other words, return non-nil if the pattern for what can be matched +for an end-tag is equivalent to empty." + (rng-ipattern-empty-before-p rng-match-state)) + +(defun rng-match-infer-start-tag-namespace (local-name) + (let ((ncs (rng-ipattern-possible-start-tags rng-match-state nil)) + (nc nil) + (ns nil)) + (while ncs + (setq nc (car ncs)) + (if (and (equal (cdr nc) local-name) + (symbolp (car nc))) + (cond ((not ns) + ;; first possible namespace + (setq ns (car nc)) + (setq ncs (cdr ncs))) + ((equal ns (car nc)) + ;; same as first namespace + (setq ncs (cdr ncs))) + (t + ;; more than one possible namespace + (setq ns nil) + (setq ncs nil))) + (setq ncs (cdr ncs)))) + ns)) + +(defun rng-match-nullable-p () + (rng-ipattern-get-nullable rng-match-state)) + +(defun rng-match-possible-start-tag-names () + "Return a list of possible names that would be valid for start-tags. + +Each possible name is returned as a (NAMESPACE . LOCAL-NAME) pair, +where NAMESPACE is a symbol or nil (meaning the absent namespace) and +LOCAL-NAME is a string. The returned list may contain duplicates." + (rng-ipattern-possible-start-tags rng-match-state nil)) + +;; This is no longer used. It might be useful so leave it in for now. +(defun rng-match-start-tag-possible-p () + "Return non-nil if a start-tag is possible." + (rng-ipattern-start-tag-possible-p rng-match-state)) + +(defun rng-match-possible-attribute-names () + "Return a list of possible names that would be valid for attributes. + +See the function `rng-match-possible-start-tag-names' for +more information." + (rng-ipattern-possible-attributes rng-match-state nil)) + +(defun rng-match-possible-value-strings () + "Return a list of strings that would be valid as content. +The list may contain duplicates. Typically, the list will not +be exhaustive." + (rng-ipattern-possible-values rng-match-state nil)) + +(defun rng-match-required-element-name () + "Return the name of an element which must occur, or nil if none." + (rng-ipattern-required-element rng-match-state)) + +(defun rng-match-required-attribute-names () + "Return a list of names of attributes which must all occur." + (rng-ipattern-required-attributes rng-match-state nil)) + +(defmacro rng-match-save (&rest body) + (let ((state (make-symbol "state"))) + `(let ((,state rng-match-state)) + (unwind-protect + (progn ,@body) + (setq rng-match-state ,state))))) + +(put 'rng-match-save 'lisp-indent-function 0) +(def-edebug-spec rng-match-save t) + +(defmacro rng-match-with-schema (schema &rest body) + `(let ((rng-current-schema ,schema) + rng-match-state + rng-compile-table + rng-ipattern-table + rng-last-ipattern-index) + (rng-ipattern-maybe-init) + (rng-compile-maybe-init) + (setq rng-match-state (rng-compile rng-current-schema)) + ,@body)) + +(put 'rng-match-with-schema 'lisp-indent-function 1) +(def-edebug-spec rng-match-with-schema t) + +(provide 'rng-match) + +;; arch-tag: c8c50733-edcf-49fb-85e2-0aac8749b7f8 +;;; rng-match.el ends here diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el new file mode 100644 index 00000000000..0e65dc09b4d --- /dev/null +++ b/lisp/nxml/rng-nxml.el @@ -0,0 +1,594 @@ +;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(require 'easymenu) +(require 'xmltok) +(require 'nxml-util) +(require 'nxml-ns) +(require 'rng-match) +(require 'rng-util) +(require 'rng-valid) +(require 'nxml-mode) +(require 'rng-loc) + +(defcustom rng-nxml-auto-validate-flag t + "*Non-nil means automatically turn on validation with nxml-mode." + :type 'boolean + :group 'relax-ng) + +(defvar rng-preferred-prefix-alist-default nil + "Default value for variable `rng-preferred-prefix-alist'.") + +(defcustom rng-preferred-prefix-alist rng-preferred-prefix-alist-default + "*Alist of namespaces vs preferred prefixes." + :type '(repeat (cons :tag "With" + (string :tag "this namespace URI") + (string :tag "use this prefix"))) + :group 'relax-ng) + +(defvar rng-complete-end-tags-after-< t + "*Non-nil means immediately after < complete on end-tag names. +Complete on start-tag names regardless.") + +(defvar rng-nxml-easy-menu + '("XML" + ["Show Outline Only" nxml-hide-all-text-content] + ["Show Everything" nxml-show-all] + "---" + ["Validation" rng-validate-mode + :style toggle + :selected rng-validate-mode] + "---" + ("Set Schema" + ["Automatically" rng-auto-set-schema] + ("For Document Type" + :filter (lambda (menu) + (mapcar (lambda (type-id) + (vector type-id + (list 'rng-set-document-type + type-id))) + (rng-possible-type-ids)))) + ["Any Well-Formed XML" rng-set-vacuous-schema] + ["File..." rng-set-schema-file]) + ["Show Schema Location" rng-what-schema] + ["Save Schema Location" rng-save-schema-location :help + "Save the location of the schema currently being used for this buffer"] + "---" + ["First Error" rng-first-error :active rng-validate-mode] + ["Next Error" rng-next-error :active rng-validate-mode] + "---" + ["Customize nXML" (customize-group 'nxml)] + "---" + ["Show nXML Version" nxml-version])) + +;;;###autoload +(defun rng-nxml-mode-init () + "Initialize `nxml-mode' to take advantage of `rng-validate-mode'. +This is typically called from `nxml-mode-hook'. +Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." + (interactive) + (define-key nxml-mode-map "\C-c\C-v" 'rng-validate-mode) + (define-key nxml-mode-map "\C-c\C-s\C-w" 'rng-what-schema) + (define-key nxml-mode-map "\C-c\C-s\C-a" 'rng-auto-set-schema-and-validate) + (define-key nxml-mode-map "\C-c\C-s\C-f" 'rng-set-schema-file-and-validate) + (define-key nxml-mode-map "\C-c\C-s\C-l" 'rng-save-schema-location) + (define-key nxml-mode-map "\C-c\C-s\C-t" 'rng-set-document-type-and-validate) + (define-key nxml-mode-map "\C-c\C-n" 'rng-next-error) + (easy-menu-define rng-nxml-menu nxml-mode-map + "Menu for nxml-mode used with rng-validate-mode." + rng-nxml-easy-menu) + (setq mode-line-process + '(rng-validate-mode (:eval (rng-compute-mode-line-string)))) + (cond (rng-nxml-auto-validate-flag + (rng-validate-mode 1) + (add-hook 'nxml-completion-hook 'rng-complete nil t) + (add-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p nil t)) + (t + (rng-validate-mode 0) + (remove-hook 'nxml-completion-hook 'rng-complete t) + (remove-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p t)))) + +(defvar rng-tag-history nil) +(defvar rng-attribute-name-history nil) +(defvar rng-attribute-value-history nil) + +(defvar rng-complete-target-names nil) +(defvar rng-complete-name-attribute-flag nil) +(defvar rng-complete-extra-strings nil) + +(defun rng-complete () + "Complete the string before point using the current schema. +Return non-nil if in a context it understands." + (interactive) + (and rng-validate-mode + (let ((lt-pos (save-excursion (search-backward "<" nil t))) + xmltok-dtd) + (and lt-pos + (= (rng-set-state-after lt-pos) lt-pos) + (or (rng-complete-tag lt-pos) + (rng-complete-end-tag lt-pos) + (rng-complete-attribute-name lt-pos) + (rng-complete-attribute-value lt-pos)))))) + +(defconst rng-in-start-tag-name-regex + (replace-regexp-in-string + "w" + xmltok-ncname-regexp + "<\\(?:w\\(?::w?\\)?\\)?\\=" + t + t)) + +(defun rng-complete-tag (lt-pos) + (let (rng-complete-extra-strings) + (when (and (= lt-pos (1- (point))) + rng-complete-end-tags-after-< + rng-open-elements + (not (eq (car rng-open-elements) t)) + (or rng-collecting-text + (rng-match-save + (rng-match-end-tag)))) + (setq rng-complete-extra-strings + (cons (concat "/" + (if (caar rng-open-elements) + (concat (caar rng-open-elements) + ":" + (cdar rng-open-elements)) + (cdar rng-open-elements))) + rng-complete-extra-strings))) + (when (save-excursion + (re-search-backward rng-in-start-tag-name-regex + lt-pos + t)) + (and rng-collecting-text (rng-flush-text)) + (let ((completion + (let ((rng-complete-target-names + (rng-match-possible-start-tag-names)) + (rng-complete-name-attribute-flag nil)) + (rng-complete-before-point (1+ lt-pos) + 'rng-complete-qname-function + "Tag: " + nil + 'rng-tag-history))) + name) + (when completion + (cond ((rng-qname-p completion) + (setq name (rng-expand-qname completion + t + 'rng-start-tag-expand-recover)) + (when (and name + (rng-match-start-tag-open name) + (or (not (rng-match-start-tag-close)) + ;; need a namespace decl on the root element + (and (car name) + (not rng-open-elements)))) + ;; attributes are required + (insert " "))) + ((member completion rng-complete-extra-strings) + (insert ">"))))) + t))) + +(defconst rng-in-end-tag-name-regex + (replace-regexp-in-string + "w" + xmltok-ncname-regexp + "</\\(?:w\\(?::w?\\)?\\)?\\=" + t + t)) + +(defun rng-complete-end-tag (lt-pos) + (when (save-excursion + (re-search-backward rng-in-end-tag-name-regex + lt-pos + t)) + (cond ((or (not rng-open-elements) + (eq (car rng-open-elements) t)) + (message "No matching start-tag") + (ding)) + (t + (let ((start-tag-name + (if (caar rng-open-elements) + (concat (caar rng-open-elements) + ":" + (cdar rng-open-elements)) + (cdar rng-open-elements))) + (end-tag-name + (buffer-substring-no-properties (+ (match-beginning 0) 2) + (point)))) + (cond ((or (> (length end-tag-name) + (length start-tag-name)) + (not (string= (substring start-tag-name + 0 + (length end-tag-name)) + end-tag-name))) + (message "Expected end-tag %s" + (rng-quote-string + (concat "</" start-tag-name ">"))) + (ding)) + (t + (delete-region (- (point) (length end-tag-name)) + (point)) + (insert start-tag-name ">") + (when (not (or rng-collecting-text + (rng-match-end-tag))) + (message "Element %s is incomplete" + (rng-quote-string start-tag-name)))))))) + t)) + +(defconst rng-in-attribute-regex + (replace-regexp-in-string + "w" + xmltok-ncname-regexp + "<w\\(?::w\\)?\ +\\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\ +[ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\ +[ \t\r\n]+\\(\\(?:w\\(?::w?\\)?\\)?\\)\\=" + t + t)) + +(defvar rng-undeclared-prefixes nil) + +(defun rng-complete-attribute-name (lt-pos) + (when (save-excursion + (re-search-backward rng-in-attribute-regex lt-pos t)) + (let ((attribute-start (match-beginning 1)) + rng-undeclared-prefixes) + (and (rng-adjust-state-for-attribute lt-pos + attribute-start) + (let ((rng-complete-target-names + (rng-match-possible-attribute-names)) + (rng-complete-extra-strings + (mapcar (lambda (prefix) + (if prefix + (concat "xmlns:" prefix) + "xmlns")) + rng-undeclared-prefixes)) + (rng-complete-name-attribute-flag t)) + (rng-complete-before-point attribute-start + 'rng-complete-qname-function + "Attribute: " + nil + 'rng-attribute-name-history)) + (insert "=\""))) + t)) + +(defconst rng-in-attribute-value-regex + (replace-regexp-in-string + "w" + xmltok-ncname-regexp + "<w\\(?::w\\)?\ +\\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\ +[ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\ +[ \t\r\n]+\\(w\\(:w\\)?\\)[ \t\r\n]*=[ \t\r\n]*\ +\\(\"[^\"]*\\|'[^']*\\)\\=" + t + t)) + +(defun rng-complete-attribute-value (lt-pos) + (when (save-excursion + (re-search-backward rng-in-attribute-value-regex lt-pos t)) + (let ((name-start (match-beginning 1)) + (name-end (match-end 1)) + (colon (match-beginning 2)) + (value-start (1+ (match-beginning 3)))) + (and (rng-adjust-state-for-attribute lt-pos + name-start) + (if (string= (buffer-substring-no-properties name-start + (or colon name-end)) + "xmlns") + (rng-complete-before-point + value-start + (rng-strings-to-completion-alist + (rng-possible-namespace-uris + (and colon + (buffer-substring-no-properties (1+ colon) name-end)))) + "Namespace URI: " + nil + 'rng-namespace-uri-history) + (rng-adjust-state-for-attribute-value name-start + colon + name-end) + (rng-complete-before-point + value-start + (rng-strings-to-completion-alist + (rng-match-possible-value-strings)) + "Value: " + nil + 'rng-attribute-value-history)) + (insert (char-before value-start)))) + t)) + +(defun rng-possible-namespace-uris (prefix) + (let ((ns (if prefix (nxml-ns-get-prefix prefix) + (nxml-ns-get-default)))) + (if (and ns (memq prefix (nxml-ns-changed-prefixes))) + (list (nxml-namespace-name ns)) + (mapcar 'nxml-namespace-name + (delq nxml-xml-namespace-uri + (rng-match-possible-namespace-uris)))))) + +(defconst rng-qname-regexp + (concat "\\`" + xmltok-ncname-regexp + "\\(?:" ":" xmltok-ncname-regexp "\\)" "?" "\\'")) + +(defun rng-qname-p (string) + (and (string-match rng-qname-regexp string) t)) + +(defun rng-expand-qname (qname &optional defaultp recover-fun) + (setq qname (rng-split-qname qname)) + (let ((prefix (car qname))) + (if prefix + (let ((ns (nxml-ns-get-prefix qname))) + (cond (ns (cons ns (cdr qname))) + (recover-fun (funcall recover-fun prefix (cdr qname))))) + (cons (and defaultp (nxml-ns-get-default)) (cdr qname))))) + +(defun rng-start-tag-expand-recover (prefix local-name) + (let ((ns (rng-match-infer-start-tag-namespace local-name))) + (and ns + (cons ns local-name)))) + +(defun rng-split-qname (qname) + (if (string-match ":" qname) + (cons (substring qname 0 (match-beginning 0)) + (substring qname (match-end 0))) + (cons nil qname))) + +(defun rng-in-mixed-content-p () + "Return non-nil if point is in mixed content. +Return nil only if point is definitely not in mixed content. +If unsure, return non-nil." + (if (eq rng-current-schema rng-any-element) + t + (rng-set-state-after) + (rng-match-mixed-text))) + +(defun rng-set-state-after (&optional pos) + "Set the state for after parsing the first token with endpoint >= POS. +This does not change the xmltok state or point. However, it does +set `xmltok-dtd'. Returns the position of the end of the token." + (unless pos (setq pos (point))) + (when (< rng-validate-up-to-date-end pos) + (message "Parsing...") + (while (and (rng-do-some-validation) + (< rng-validate-up-to-date-end pos)) + ;; Display percentage validated. + (force-mode-line-update) + ;; Force redisplay but don't allow idle timers to run. + (let ((timer-idle-list nil)) + (sit-for 0))) + (message "Parsing...done")) + (save-excursion + (save-restriction + (widen) + (nxml-with-invisible-motion + (if (= pos 1) + (rng-set-initial-state) + (let ((state (get-text-property (1- pos) 'rng-state))) + (cond (state + (rng-restore-state state) + (goto-char pos)) + (t + (let ((start (previous-single-property-change pos + 'rng-state))) + (cond (start + (rng-restore-state (get-text-property (1- start) + 'rng-state)) + (goto-char start)) + (t (rng-set-initial-state)))))))) + (xmltok-save + (if (= (point) 1) + (xmltok-forward-prolog) + (setq xmltok-dtd rng-dtd)) + (cond ((and (< pos (point)) + ;; This handles the case where the prolog ends + ;; with a < without any following name-start + ;; character. This will be treated by the parser + ;; as part of the prolog, but we want to treat + ;; it as the start of the instance. + (eq (char-after pos) ?<) + (<= (point) + (save-excursion + (goto-char (1+ pos)) + (skip-chars-forward " \t\r\n") + (point)))) + pos) + ((< (point) pos) + (let ((rng-dt-namespace-context-getter + '(nxml-ns-get-context)) + (rng-parsing-for-state t)) + (rng-forward pos)) + (point)) + (t pos))))))) + +(defun rng-adjust-state-for-attribute (lt-pos start) + (xmltok-save + (save-excursion + (goto-char lt-pos) + (when (memq (xmltok-forward) + '(start-tag + partial-start-tag + empty-element + partial-empty-element)) + (when (< start (point)) + (setq xmltok-namespace-attributes + (rng-prune-attribute-at start + xmltok-namespace-attributes)) + (setq xmltok-attributes + (rng-prune-attribute-at start + xmltok-attributes))) + (let ((rng-parsing-for-state t) + (rng-dt-namespace-context-getter '(nxml-ns-get-context))) + (rng-process-start-tag 'stop) + (rng-find-undeclared-prefixes) + t))))) + +(defun rng-find-undeclared-prefixes () + ;; Start with the newly effective namespace declarations. + ;; (Includes declarations added during recovery.) + (setq rng-undeclared-prefixes (nxml-ns-changed-prefixes)) + (let ((iter xmltok-attributes) + (ns-state (nxml-ns-state)) + att) + ;; Add namespace prefixes used in this tag, + ;; but not declared in the parent. + (nxml-ns-pop-state) + (while iter + (setq att (car iter)) + (let ((prefix (xmltok-attribute-prefix att))) + (when (and prefix + (not (member prefix rng-undeclared-prefixes)) + (not (nxml-ns-get-prefix prefix))) + (setq rng-undeclared-prefixes + (cons prefix rng-undeclared-prefixes)))) + (setq iter (cdr iter))) + (nxml-ns-set-state ns-state) + ;; Remove namespace prefixes explicitly declared. + (setq iter xmltok-namespace-attributes) + (while iter + (setq att (car iter)) + (setq rng-undeclared-prefixes + (delete (and (xmltok-attribute-prefix att) + (xmltok-attribute-local-name att)) + rng-undeclared-prefixes)) + (setq iter (cdr iter))))) + +(defun rng-prune-attribute-at (start atts) + (when atts + (let ((cur atts)) + (while (if (eq (xmltok-attribute-name-start (car cur)) start) + (progn + (setq atts (delq (car cur) atts)) + nil) + (setq cur (cdr cur))))) + atts)) + +(defun rng-adjust-state-for-attribute-value (name-start + colon + name-end) + (let* ((prefix (if colon + (buffer-substring-no-properties name-start colon) + nil)) + (local-name (buffer-substring-no-properties (if colon + (1+ colon) + name-start) + name-end)) + (ns (and prefix (nxml-ns-get-prefix prefix)))) + (and (or (not prefix) ns) + (rng-match-attribute-name (cons ns local-name))))) + +(defun rng-complete-qname-function (string predicate flag) + (let ((alist (mapcar (lambda (name) (cons name nil)) + (rng-generate-qname-list string)))) + (cond ((not flag) + (try-completion string alist predicate)) + ((eq flag t) + (all-completions string alist predicate)) + ((eq flag 'lambda) + (and (assoc string alist) t))))) + +(defun rng-generate-qname-list (&optional string) + (let ((forced-prefix (and string + (string-match ":" string) + (> (match-beginning 0) 0) + (substring string + 0 + (match-beginning 0)))) + (namespaces (mapcar 'car rng-complete-target-names)) + ns-prefixes-alist ns-prefixes iter ns prefer) + (while namespaces + (setq ns (car namespaces)) + (when ns + (setq ns-prefixes-alist + (cons (cons ns (nxml-ns-prefixes-for + ns + rng-complete-name-attribute-flag)) + ns-prefixes-alist))) + (setq namespaces (delq ns (cdr namespaces)))) + (setq iter ns-prefixes-alist) + (while iter + (setq ns-prefixes (car iter)) + (setq ns (car ns-prefixes)) + (when (null (cdr ns-prefixes)) + ;; No declared prefix for the namespace + (if forced-prefix + ;; If namespace non-nil and prefix undeclared, + ;; use forced prefix. + (when (and ns + (not (nxml-ns-get-prefix forced-prefix))) + (setcdr ns-prefixes (list forced-prefix))) + (setq prefer (rng-get-preferred-unused-prefix ns)) + (when prefer + (setcdr ns-prefixes (list prefer))) + ;; Unless it's an attribute with a non-nil namespace, + ;; allow no prefix for this namespace. + (unless rng-complete-name-attribute-flag + (setcdr ns-prefixes (cons nil (cdr ns-prefixes)))))) + (setq iter (cdr iter))) + (rng-uniquify-equal + (sort (apply 'append + (cons rng-complete-extra-strings + (mapcar (lambda (name) + (if (car name) + (mapcar (lambda (prefix) + (if prefix + (concat prefix + ":" + (cdr name)) + (cdr name))) + (cdr (assoc (car name) + ns-prefixes-alist))) + (list (cdr name)))) + rng-complete-target-names))) + 'string<)))) + +(defun rng-get-preferred-unused-prefix (ns) + (let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist)) + iter prefix) + (when ns-prefix + (setq prefix (cdr ns-prefix)) + (when (nxml-ns-get-prefix prefix) + ;; try to find an unused prefix + (setq iter (memq ns-prefix rng-preferred-prefix-alist)) + (while (and iter + (setq ns-prefix (assoc ns iter))) + (if (nxml-ns-get-prefix (cdr ns-prefix)) + (setq iter (memq ns-prefix iter)) + (setq prefix (cdr ns-prefix)) + nil)))) + prefix)) + +(defun rng-strings-to-completion-alist (strings) + (mapcar (lambda (s) (cons s s)) + (rng-uniquify-equal (sort (mapcar 'rng-escape-string strings) + 'string<)))) + +(provide 'rng-nxml) + +;; arch-tag: bec0d6ed-6be1-4540-9c2c-6f56e8e55d8b +;;; rng-nxml.el ends here diff --git a/lisp/nxml/rng-parse.el b/lisp/nxml/rng-parse.el new file mode 100644 index 00000000000..e9d10e03f21 --- /dev/null +++ b/lisp/nxml/rng-parse.el @@ -0,0 +1,107 @@ +;;; rng-parse.el --- parse an XML file and validate it against a schema + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This combines the validation machinery in rng-match.el with the +;; parser in nxml-parse.el by using the `nxml-validate-function' hook. + +;;; Code: + +(require 'nxml-parse) +(require 'rng-match) +(require 'rng-dt) + +(defvar rng-parse-prev-was-start-tag nil) + +(defun rng-parse-validate-file (schema file) + "Parse and validate the XML document in FILE and return it as a list. +The returned list has the same form as that returned by +`nxml-parse-file'. SCHEMA is a list representing the schema to use +for validation, such as returned by the function `rng-c-load-schema'. +If the XML document is invalid with respect to schema, an error will +be signaled in the same way as when it is not well-formed." + (save-excursion + (set-buffer (nxml-parse-find-file file)) + (unwind-protect + (let ((nxml-parse-file-name file) + (nxml-validate-function 'rng-parse-do-validate) + (rng-dt-namespace-context-getter '(nxml-ns-get-context)) + rng-parse-prev-was-start-tag) + ;; We don't simply call nxml-parse-file, because + ;; we want to do rng-match-with-schema in the same + ;; buffer in which we will call the other rng-match-* functions. + (rng-match-with-schema schema + (nxml-parse-instance))) + (kill-buffer nil)))) + +(defun rng-parse-do-validate (text start-tag) + (cond ((and (let ((tem rng-parse-prev-was-start-tag)) + (setq rng-parse-prev-was-start-tag (and start-tag t)) + tem) + (not start-tag) + (rng-match-text-typed-p)) + (unless (rng-match-element-value (or text "")) + (cons "Invalid data" (and text 'text)))) + ((and text + (not (rng-blank-p text)) + (not (rng-match-mixed-text))) + (cons "Text not allowed" 'text)) + ((not start-tag) + (unless (rng-match-end-tag) + (cons "Missing elements" nil))) + ((not (rng-match-start-tag-open + (rng-parse-to-match-name (car start-tag)))) + (cons "Element not allowed" nil)) + (t + (let ((atts (cadr start-tag)) + (i 0) + att err) + (while (and atts (not err)) + (setq att (car atts)) + (when (not (and (consp (car att)) + (eq (caar att) nxml-xmlns-namespace-uri))) + (setq err + (cond ((not (rng-match-attribute-name + (rng-parse-to-match-name (car att)))) + (cons "Attribute not allowed" + (cons 'attribute-name i))) + ((not (rng-match-attribute-value (cdr att))) + (cons "Invalid attribute value" + (cons 'attribute-value i)))))) + (setq atts (cdr atts)) + (setq i (1+ i))) + (or err + (unless (rng-match-start-tag-close) + (cons "Missing attributes" 'tag-close))))))) + +(defun rng-parse-to-match-name (name) + (if (consp name) + name + (cons nil name))) + +(provide 'rng-parse) + +;; arch-tag: 8f14f533-b687-4dc0-9cd7-617ead856981 +;;; rng-parse.el ends here diff --git a/lisp/nxml/rng-pttrn.el b/lisp/nxml/rng-pttrn.el new file mode 100644 index 00000000000..2ed87943160 --- /dev/null +++ b/lisp/nxml/rng-pttrn.el @@ -0,0 +1,192 @@ +;;; rng-pttrn.el --- RELAX NG patterns + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; pattern ::= +;; (ref <pattern> <local-name>) +;; | (choice <pattern> <pattern> ...) +;; | (group <pattern> <pattern> ...) +;; | (interleave <pattern> <pattern> ...) +;; | (zero-or-more <pattern>) +;; | (one-or-more <pattern>) +;; | (optional <pattern>) +;; | (mixed <pattern>) +;; | (value <datatype> <string> <context>) +;; | (data <datatype> <params>) +;; | (data-except <datatype> <params> <pattern>) +;; | (list <pattern>) +;; | (element <name-class> <pattern>) +;; | (attribute <name-class> <pattern>) +;; | (text) +;; | (empty) +;; | (not-allowed) +;; +;; params ::= +;; ((<param-name> . <param-value> ) ...) +;; param-name ::= <symbol> +;; param-value ::= <string> +;; +;; name-class ::= +;; (name <name>) +;; | (any-name) +;; | (any-name-except <name-class>) +;; | (ns-name <ns>) +;; | (ns-name-except <ns> <name-class>) +;; | (choice <name-class> <name-class> ...) +;; +;; name ::= (<ns> . <local-name>) +;; ns ::= nil | <symbol> +;; local-name ::= <string> +;; datatype ::= (<datatype-uri> . <datatype-local-name>) +;; datatype-uri ::= nil | <symbol> +;; datatype-local-name ::= <symbol> + +;;; Code: + +(defvar rng-schema-change-hook nil + "Hook to be run after `rng-current-schema' changes.") + +(defvar rng-current-schema nil + "Pattern to be used as schema for the current buffer.") +(make-variable-buffer-local 'rng-current-schema) + +(defun rng-make-ref (name) + (list 'ref nil name)) + +(defun rng-ref-set (ref pattern) + (setcar (cdr ref) pattern)) + +(defun rng-ref-get (ref) (cadr ref)) + +(defun rng-make-choice (patterns) + (cons 'choice patterns)) + +(defun rng-make-group (patterns) + (cons 'group patterns)) + +(defun rng-make-interleave (patterns) + (cons 'interleave patterns)) + +(defun rng-make-zero-or-more (pattern) + (list 'zero-or-more pattern)) + +(defun rng-make-one-or-more (pattern) + (list 'one-or-more pattern)) + +(defun rng-make-optional (pattern) + (list 'optional pattern)) + +(defun rng-make-mixed (pattern) + (list 'mixed pattern)) + +(defun rng-make-value (datatype str context) + (list 'value datatype str context)) + +(defun rng-make-data (name params) + (list 'data name params)) + +(defun rng-make-data-except (name params pattern) + (list 'data-except name params pattern)) + +(defun rng-make-list (pattern) + (list 'list pattern)) + +(defun rng-make-element (name-class pattern) + (list 'element name-class pattern)) + +(defun rng-make-attribute (name-class pattern) + (list 'attribute name-class pattern)) + +(defun rng-make-text () + '(text)) + +(defun rng-make-empty () + '(empty)) + +(defun rng-make-not-allowed () + '(not-allowed)) + +(defun rng-make-any-name-name-class () + '(any-name)) + +(defun rng-make-any-name-except-name-class (name-class) + (list 'any-name-except name-class)) + +(defun rng-make-ns-name-name-class (ns) + (list 'ns-name ns)) + +(defun rng-make-ns-name-except-name-class (ns name-class) + (list 'ns-name-except ns name-class)) + +(defun rng-make-name-name-class (name) + (list 'name name)) + +(defun rng-make-choice-name-class (name-classes) + (cons 'choice name-classes)) + +(defconst rng-any-content + (let* ((ref (rng-make-ref "any-content")) + (pattern (rng-make-zero-or-more + (rng-make-choice + (list + (rng-make-text) + (rng-make-attribute (rng-make-any-name-name-class) + (rng-make-text)) + (rng-make-element (rng-make-any-name-name-class) + ref)))))) + (rng-ref-set ref pattern) + pattern) + "A pattern that matches the attributes and content of any element.") + +(defconst rng-any-element + (let* ((ref (rng-make-ref "any-element")) + (pattern + (rng-make-element + (rng-make-any-name-name-class) + (rng-make-zero-or-more + (rng-make-choice + (list + (rng-make-text) + (rng-make-attribute (rng-make-any-name-name-class) + (rng-make-text)) + ref)))))) + (rng-ref-set ref pattern) + pattern) + "A pattern that matches any element.") + +;;; Names + +(defun rng-make-name (ns local-name) + (cons ns local-name)) + +;;; Datatypes + +(defun rng-make-datatype (uri local-name) + (cons uri (intern local-name))) + +(provide 'rng-pttrn) + +;; arch-tag: 9418e269-ddd4-4037-861f-ff903f48f008 +;;; rng-pttrn.el ends here diff --git a/lisp/nxml/rng-uri.el b/lisp/nxml/rng-uri.el new file mode 100644 index 00000000000..f18012abcfe --- /dev/null +++ b/lisp/nxml/rng-uri.el @@ -0,0 +1,358 @@ +;;; rng-uri.el --- URI parsing and manipulation + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(defun rng-file-name-uri (f) + "Return a URI for the filename F. +Multibyte characters are left as is. Use `rng-uri-escape-multibyte' to +escape them using %HH." + (setq f (expand-file-name f)) + (let ((url + (replace-regexp-in-string "[\000-\032\177<>#%\"{}|\\^[]`%?;]" + 'rng-percent-encode + f))) + (concat "file:" + (if (and (> (length url) 0) + (= (aref url 0) ?/)) + "//" + "///") + url))) + +(defun rng-uri-escape-multibyte (uri) + "Escape multibyte characters in URI." + (replace-regexp-in-string "[:nonascii:]" + 'rng-percent-encode + (encode-coding-string uri 'utf-8))) + +(defun rng-percent-encode (str) + (apply 'concat + (mapcar (lambda (ch) + (format "%%%x%x" (/ ch 16) (% ch 16))) + (string-to-list str)))) + + +(defun rng-uri-file-name (uri) + "Return the filename represented by a URI. +Signal an error if URI is not a valid file URL." + (rng-uri-file-name-1 uri nil)) + +(defun rng-uri-pattern-file-name-regexp (pattern) + "Return a regexp for filenames represented by URIs that match PATTERN." + (rng-uri-file-name-1 pattern 'match)) + +(defun rng-uri-pattern-file-name-replace-match (pattern) + (rng-uri-file-name-1 pattern 'replace)) + +;; pattern is either nil or match or replace +(defun rng-uri-file-name-1 (uri pattern) + (unless (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F]{2}\\)*\\'" uri) + (rng-uri-error "Bad escapes in URI `%s'" uri)) + (setq uri (rng-uri-unescape-multibyte uri)) + (let* ((components + (or (rng-uri-split uri) + (rng-uri-error "Cannot split URI `%s' into its components" uri))) + (scheme (nth 0 components)) + (authority (nth 1 components)) + (path (nth 2 components)) + (absolutep (string-match "\\`/" path)) + (query (nth 3 components)) + (fragment-id (nth 4 components))) + (cond ((not scheme) + (unless pattern + (rng-uri-error "URI `%s' does not have a scheme" uri))) + ((not (string= (downcase scheme) "file")) + (rng-uri-error "URI `%s' does not use the `file:' scheme" uri))) + (when (not (member authority + (cons system-name '(nil "" "localhost")))) + (rng-uri-error "URI `%s' does not start with `file:///' or `file://localhost/'" + uri)) + (when query + (rng-uri-error "`?' not escaped in file URI `%s'" uri)) + (when fragment-id + (rng-uri-error "URI `%s' has a fragment identifier" uri)) + (when (string-match ";" path) + (rng-uri-error "`;' not escaped in URI `%s'" uri)) + (when (string-match "%2[fF]" path) ;; 2f is hex code of slash + (rng-uri-error "Escaped slash in URI `%s'" uri)) + (when (and (eq system-type 'windows-nt) + absolutep + (file-name-absolute-p (substring path 1))) + (setq path (substring path 1))) + (when (and pattern (string-match "\\`\\./" path)) + (setq path (substring path 2))) + (setq path + (cond ((eq pattern 'match) + (rng-uri-unescape-unibyte-match path)) + ((eq pattern 'replace) + (rng-uri-unescape-unibyte-replace path 2)) + (t + (rng-uri-unescape-unibyte path)))) + (when (string-match "\000" path) + (rng-uri-error "URI `%s' has NUL character in path" uri)) + (when (eq pattern 'match) + (setq path + (concat (if absolutep + "\\(\\)" + "\\(\\(?:[^/]*/\\)*\\)") + path))) + (cond ((eq pattern 'match) + (concat "\\`" path "\\'")) + ((and (eq pattern 'replace) + (not absolutep)) + (concat "\\1" path)) + (t path)))) + +(defun rng-uri-error (&rest args) + (signal 'rng-uri-error (list (apply 'format args)))) + +(put 'rng-uri-error 'error-conditions '(error rng-uri-error)) +(put 'rng-uri-error 'error-message "Invalid URI") + +(defun rng-uri-split (str) + (and (string-match "\\`\\(?:\\([^:/?#]+\\):\\)?\ +\\(?://\\([^/?#]*\\)\\)?\ +\\([^?#]*\\)\ +\\(?:\\?\\([^#]*\\)\\)?\ +\\(?:#\\(\\(?:.\\|\n\\)*\\)\\)?\\'" + str) + (list (match-string 1 str) + (match-string 2 str) + (match-string 3 str) + (match-string 4 str) + (match-string 5 str)))) + +(defun rng-uri-join (scheme authority path &optional query fragment-id) + (when path + (let (parts) + (when fragment-id + (setq parts (list "#" fragment-id))) + (when query + (setq parts + (cons "?" + (cons query parts)))) + (setq parts (cons path parts)) + (when authority + (setq parts + (cons "//" + (cons authority parts)))) + (when scheme + (setq parts + (cons scheme + (cons ":" parts)))) + (apply 'concat parts)))) + +(defun rng-uri-resolve (uri-ref base-uri) + "Resolve a possibly relative URI reference into absolute form. +URI-REF is the URI reference to be resolved. +BASE-URI is the base URI to use for resolving it. +The algorithm is specified by RFC 2396. +If there is some problem with URI-REF or BASE-URI, then +URI-REF will be returned." + (let* ((components (rng-uri-split uri-ref)) + (scheme (nth 0 components)) + (authority (nth 1 components)) + (path (nth 2 components)) + (query (nth 3 components)) + (fragment-id (nth 4 components)) + (base-components (rng-uri-split base-uri))) + (if (or (not components) + scheme + (not base-components) + (not (nth 0 base-components))) + uri-ref + (setq scheme (nth 0 base-components)) + (when (not authority) + (setq authority (nth 1 base-components)) + (if (and (equal path "") (not query)) + ;; Handle same document reference by returning + ;; same URI (RFC 2396bis does this too). + (setq path (nth 2 base-components) + query (nth 3 base-components)) + (setq path (rng-resolve-path path (nth 2 base-components))))) + (rng-uri-join scheme + authority + path + query + fragment-id)))) + +;; See RFC 2396 5.2, steps 5 and 6 +(defun rng-resolve-path (path base-path) + ;; Step 5 + (if (or (string-match "\\`/" path) + (not (string-match "\\`/" base-path))) + path + ;; Step 6 + ;; (a), (b) + (let ((segments (rng-split-path path)) + (base-segments (rng-split-path base-path))) + (if (> (length base-segments) 1) + (setq segments (nconc (nbutlast base-segments) + segments)) + (setcar segments + (concat (car base-segments) (car segments)))) + ;; (d) + (let ((last-segment (last segments))) + (when (equal (car last-segment) ".") + (setcar last-segment ""))) + ;; (c) + (setq segments (delete "." segments)) + ;; (e) + (let (iter matched) + (while (progn + (setq matched nil) + (setq iter (cdr segments)) + (while (and iter (not matched)) + (if (or (not (equal (cadr iter) "..")) + (equal (car iter) "..")) + (setq iter (cdr iter)) + (setcar iter nil) + (setcar (cdr iter) + ;; (f) + (if (cddr iter) nil "")) + (setq matched t) + (setq segments (delq nil segments)))) + matched))) + (rng-join-path segments)))) + +(defun rng-relative-uri (full base) + "Return a URI that relative to BASE is equivalent to FULL. +The returned URI will be relative if possible. +Both FULL and BASE must be absolute URIs." + (let* ((components (rng-uri-split full)) + (scheme (nth 0 components)) + (authority (nth 1 components)) + (path (nth 2 components)) + (query (nth 3 components)) + (fragment-id (nth 4 components)) + (base-components (rng-uri-split base))) + (if (and components + base-components + scheme + (equal scheme + (nth 0 base-components))) + (progn + (setq scheme nil) + (when (and authority + (equal authority + (nth 1 base-components))) + (setq authority nil) + (setq path (rng-relative-path path (nth 2 base-components)))) + (rng-uri-join scheme authority path query fragment-id)) + full))) + +(defun rng-relative-path (path base-path) + (let ((segments (rng-split-path path)) + (base-segments (rng-split-path base-path))) + (when (> (length base-segments) 1) + (setq base-segments (nbutlast base-segments))) + (if (or (member "." segments) + (member ".." segments) + (member "." base-segments) + (member ".." base-segments)) + path + (while (and segments + base-segments + (string= (car segments) + (car base-segments))) + (setq segments (cdr segments)) + (setq base-segments (cdr base-segments))) + (while base-segments + (setq base-segments (cdr base-segments)) + (setq segments (cons ".." segments))) + (when (equal (car segments) "") + (setq segments (cons "." segments))) + (rng-join-path segments)))) + +(defun rng-split-path (path) + (let ((start 0) + segments) + (while (string-match "/" path start) + (setq segments (cons (substring path start (match-beginning 0)) + segments)) + (setq start (match-end 0))) + (nreverse (cons (substring path start) segments)))) + +(defun rng-join-path (segments) + (and segments + (mapconcat 'identity segments "/"))) + +(defun rng-uri-unescape-multibyte (str) + (replace-regexp-in-string "\\(?:%[89a-fA-F][0-9a-fA-F]\\)+" + 'rng-multibyte-percent-decode + str)) + +(defun rng-multibyte-percent-decode (str) + (decode-coding-string (apply 'string + (mapcar (lambda (h) (string-to-number h 16)) + (split-string str "%"))) + 'utf-8)) + +(defun rng-uri-unescape-unibyte (str) + (replace-regexp-in-string "%[0-7][0-9a-fA-F]" + (lambda (h) + (string-to-number (substring h 1) 16)) + str + t + t)) + +(defun rng-uri-unescape-unibyte-match (str) + (replace-regexp-in-string "%[0-7][0-9a-fA-F]\\|[^%]" + (lambda (match) + (if (string= match "*") + "\\([^/]*\\)" + (regexp-quote + (if (= (length match) 1) + match + (string-to-number (substring match 1) + 16))))) + str + t + t)) + +(defun rng-uri-unescape-unibyte-replace (str next-match-index) + (replace-regexp-in-string + "%[0-7][0-9a-fA-F]\\|[^%]" + (lambda (match) + (if (string= match "*") + (let ((n next-match-index)) + (setq next-match-index (1+ n)) + (format "\\%s" n)) + (let ((ch (if (= (length match) 1) + (aref match 0) + (string-to-number (substring match 1) + 16)))) + (if (eq ch ?\\) + (string ?\\ ?\\) + (string ch))))) + str + t + t)) + +(provide 'rng-uri) + +;; arch-tag: c7b7b8b8-61d1-48ec-82bc-7001c70b2e9d +;;; rng-uri.el ends here diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el new file mode 100644 index 00000000000..7ae75f8a607 --- /dev/null +++ b/lisp/nxml/rng-util.el @@ -0,0 +1,175 @@ +;;; rng-util.el --- utility functions for RELAX NG library + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +(defun rng-make-datatypes-uri (uri) + (if (string-equal uri "") + ;; The spec doesn't say to do this, but it's perfectly conformant + ;; and better than using nil, I think. + 'http://relaxng.org/ns/structure/1.0 + (intern uri))) + +(defconst rng-xsd-datatypes-uri + (rng-make-datatypes-uri "http://www.w3.org/2001/XMLSchema-datatypes")) + +(defconst rng-builtin-datatypes-uri (rng-make-datatypes-uri "")) + +(defun rng-uniquify-eq (list) + "Destructively remove any element from LIST that is eq to +its predecessor." + (and list + (let ((head list)) + (while (cdr head) + (if (eq (car head) (cadr head)) + (setcdr head (cddr head))) + (setq head (cdr head))) + list))) + +(defun rng-uniquify-equal (list) + "Destructively remove any element from LIST that is equal to +its predecessor." + (and list + (let ((head list)) + (while (cdr head) + (if (equal (car head) (cadr head)) + (setcdr head (cddr head))) + (setq head (cdr head))) + list))) + +(defun rng-blank-p (str) (string-match "\\`[ \t\n\r]*\\'" str)) + +(defun rng-substq (new old list) + "Replace first member of LIST (if any) that is eq to OLD by NEW. +LIST is not modified." + (cond ((null list) nil) + ((eq (car list) old) + (cons new (cdr list))) + (t + (let ((tail (cons (car list) + nil)) + (rest (cdr list))) + (setq list tail) + (while rest + (let ((item (car rest))) + (setq rest (cdr rest)) + (cond ((eq item old) + (setcdr tail + (cons new rest)) + (setq rest nil)) + (t + (setq tail + (setcdr tail + (cons item nil)))))))) + list))) + +(defun rng-complete-before-point (start table prompt &optional predicate hist) + "Complete text between START and point. +Replaces the text between START and point with a string chosen using a +completion table and, when needed, input read from the user with the +minibuffer. +Returns the new string if either a complete and unique completion was +determined automatically or input was read from the user. Otherwise, +returns nil. +TABLE is an alist, a symbol bound to a function or an obarray as with +the function `completing-read'. +PROMPT is the string to prompt with if user input is needed. +PREDICATE is nil or a function as with `completing-read'. +HIST, if non-nil, specifies a history list as with `completing-read'." + (let* ((orig (buffer-substring-no-properties start (point))) + (completion (try-completion orig table predicate))) + (cond ((not completion) + (if (string= orig "") + (message "No completions available") + (message "No completion for %s" (rng-quote-string orig))) + (ding) + nil) + ((eq completion t) orig) + ((not (string= completion orig)) + (delete-region start (point)) + (insert completion) + (cond ((not (rng-completion-exact-p completion table predicate)) + (message "Incomplete") + nil) + ((eq (try-completion completion table predicate) t) + completion) + (t + (message "Complete but not unique") + nil))) + (t + (setq completion + (let ((saved-minibuffer-setup-hook + (default-value 'minibuffer-setup-hook))) + (add-hook 'minibuffer-setup-hook + 'minibuffer-completion-help + t) + (unwind-protect + (completing-read prompt + table + predicate + nil + orig + hist) + (setq-default minibuffer-setup-hook + saved-minibuffer-setup-hook)))) + (delete-region start (point)) + (insert completion) + completion)))) + +(defun rng-completion-exact-p (string table predicate) + (cond ((symbolp table) + (funcall table string predicate 'lambda)) + ((vectorp table) + (intern-soft string table)) + (t (assoc string table)))) + +(defun rng-quote-string (s) + (concat "\"" s "\"")) + +(defun rng-escape-string (s) + (replace-regexp-in-string "[&\"<>]" + (lambda (match) + (cdr (assoc match + '(("&" . "&") + ("\"" . """) + (">" . ">") + ("<" . "<"))))) + s + t)) + +(defun rng-collapse-space (string) + (setq string + (replace-regexp-in-string "[ \t\r\n]+" " " string t t)) + (when (string-match "\\` " string) + (setq string (substring string 1))) + (when (string-match " \\'" string) + (setq string (substring string 0 -1))) + string) + +(provide 'rng-util) + +;; arch-tag: 2dc233e0-5e7a-488f-bfc4-5909512dbaf0 +;;; rng-util.el ends here diff --git a/lisp/nxml/rng-valid.el b/lisp/nxml/rng-valid.el new file mode 100644 index 00000000000..183fb2561c1 --- /dev/null +++ b/lisp/nxml/rng-valid.el @@ -0,0 +1,1470 @@ +;;; rng-valid.el --- real-time validation of XML using RELAX NG + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; For usage information, see the documentation for rng-validate-mode. +;; +;; This file provides a minor mode that continually validates a buffer +;; against a RELAX NG schema. The validation state is used to support +;; schema-sensitive editing as well as validation. Validation is +;; performed while Emacs is idle. XML parsing is done using +;; xmltok.el. This file is responsible for checking that end-tags +;; match their start-tags. Namespace processing is handled by +;; nxml-ns.el. The RELAX NG Compact Syntax schema is parsed into +;; internal form by rng-cmpct.el. This internal form is described by +;; rng-pttrn.el. Validation of the document by matching against this +;; internal form is done by rng-match.el. Handling of W3C XML Schema +;; datatypes is delegated by rng-match.el to rng-xsd.el. The minor +;; mode is intended to be used in conjunction with the nxml major +;; mode, but does not have to be. +;; +;; The major responsibility of this file is to allow validation to +;; happen incrementally. If a buffer has been validated and is then +;; changed, we can often revalidate it without having to completely +;; parse and validate it from start to end. As we parse and validate +;; the buffer, we periodically cache the state. The state has three +;; components: the stack of open elements, the namespace processing +;; state and the RELAX NG validation state. The state is cached as the +;; value of the rng-state text property on the closing greater-than of +;; tags (but at intervals, not on every tag). We keep track of the +;; position up to which cached state is known to be correct by adding +;; a function to the buffer's after-change-functions. This is stored +;; in the rng-validate-up-to-date-end variable. The first way in +;; which we make validation incremental is obvious: we start +;; validation from the first cached state before +;; rng-validate-up-to-date-end. +;; +;; To make this work efficiently, we have to be able to copy the +;; current parsing and validation state efficiently. We do this by +;; minimizing destructive changes to the objects storing the state. +;; When state is changed, we use the old state to create new objects +;; representing the new state rather than destructively modifying the +;; objects representing the old state. Copying the state is just a +;; matter of making a list of three objects, one for each component of +;; the state; the three objects themselves can be shared and do not +;; need to be copied. +;; +;; There's one other idea that is used to make validation incremental. +;; Suppose we have a buffer that's 4000 bytes long and suppose we +;; validated it, caching state at positions 1000, 2000 and 3000. Now +;; suppose we make a change at position 1500 inserting 100 characters. +;; rng-validate-up-to-date-end will be changed to 1500. When Emacs +;; becomes idle and we revalidate, validation will restart using the +;; cached state at position 1000. However, we take advantage of the +;; cached state beyond rng-validate-up-to-date-end as follows. When +;; our validation reaches position 2100 (the current position of the +;; character that was at 2000), we compare our current state with the +;; cached state. If they are the same, then we can stop parsing +;; immediately and set rng-validate-up-to-date-end to the end of the +;; buffer: we already know that the state cached at position 3100 is +;; correct. If they are not the same, then we have to continue +;; parsing. After the change, but before revalidation, we call the +;; region from 1600 to the end of the buffer "conditionally +;; up-to-date". +;; +;; As well as the cached parsing and validation state, we also keep +;; track of the errors in the file. Errors are stored as overlays +;; with a category of rng-error. The number of such overlays in the +;; buffer must always be equal to rng-error-count. + +;;; Code: + +(require 'xmltok) +(require 'nxml-enc) +(require 'nxml-util) +(require 'nxml-ns) +(require 'rng-match) +(require 'rng-util) +(require 'rng-loc) + +;;; Customizable variables + +(defgroup relax-ng nil + "Validation of XML using RELAX NG." + :group 'wp + :group 'nxml + :group 'languages) + +(defface rng-error-face '((t (:underline "red"))) + "Face for highlighting XML errors." + :group 'relax-ng) + +(defcustom rng-state-cache-distance 2000 + "*Distance in characters between each parsing and validation state cache." + :type 'integer + :group 'relax-ng) + +(defcustom rng-validate-chunk-size 8000 + "*Number of characters in a RELAX NG validation chunk. +A validation chunk will be the smallest chunk that is at least this +size and ends with a tag. After validating a chunk, validation will +continue only if Emacs is still idle." + :type 'integer + :group 'relax-ng) + +(defcustom rng-validate-delay 1.5 + "*Time in seconds that Emacs must be idle before starting a full validation. +A full validation continues until either validation is up to date +or Emacs is no longer idle." + :type 'number + :group 'relax-ng) + +(defcustom rng-validate-quick-delay 0.3 + "*Time in seconds that Emacs must be idle before starting a quick validation. +A quick validation validates at most one chunk." + :type 'number + :group 'relax-ng) + +;; Global variables + +(defvar rng-validate-timer nil) +(make-variable-buffer-local 'rng-validate-timer) +;; ensure that we can cancel the timer even after a kill-all-local-variables +(put 'rng-validate-timer 'permanent-local t) + +(defvar rng-validate-quick-timer nil) +(make-variable-buffer-local 'rng-validate-quick-timer) +;; ensure that we can cancel the timer even after a kill-all-local-variables +(put 'rng-validate-quick-timer 'permanent-local t) + +(defvar rng-error-count nil + "Number of errors in the current buffer. Always equal to number of +overlays with category rng-error.") +(make-variable-buffer-local 'rng-error-count) + +(defvar rng-message-overlay nil + "Overlay in this buffer whose help-echo property was last printed. +Nil if none.") +(make-variable-buffer-local 'rng-message-overlay) + +(defvar rng-message-overlay-inhibit-point nil + "Position at which message from overlay should be inhibited. +If point is equal to this and the error overlay around +point is `rng-message-overlay', then the `help-echo' property +of the error overlay should not be printed with `message'.") +(make-variable-buffer-local 'rng-message-overlay-inhibit-point) + +(defvar rng-message-overlay-current nil + "Non-nil if `rng-message-overlay' is still the current message.") +(make-variable-buffer-local 'rng-message-overlay-current) + +(defvar rng-open-elements nil + "Stack of names of open elements represented as a list. +Each member of the list is either t or a (PREFIX . LOCAL-NAME) pair. +\(PREFIX . LOCAL-NAME) is pushed for a start-tag; t is pushed +for a mismatched end-tag.") + +(defvar rng-pending-contents nil + "Text content of current element that has yet to be processed. +Value is a list of segments (VALUE START END) positions in reverse +order. VALUE is a string or nil. If VALUE is nil, then the value is +the string between START and END. A segment can also be nil +indicating an unresolvable entity or character reference.") + +(defvar rng-collecting-text nil) + +(defvar rng-validate-up-to-date-end nil + "Last position where validation is known to be up to date.") +(make-variable-buffer-local 'rng-validate-up-to-date-end) + +(defvar rng-conditional-up-to-date-start nil + "Marker for the start of the conditionally up-to-date region. +Nil if there is no conditionally up-to-date region. The conditionally +up-to-date region must be such that for any cached state S with +position P in the conditionally up-to-date region, if at some point it +is determined that S becomes correct for P, then all states with +position >= P in the conditionally up to date region must also then be +correct and all errors between P and the end of the region must then +be correctly marked.") +(make-variable-buffer-local 'rng-conditional-up-to-date-start) + +(defvar rng-conditional-up-to-date-end nil + "Marker for the end of the conditionally up-to-date region. +Nil if there is no conditionally up-to-date region. See the variable +`rng-conditional-up-to-date-start'.") +(make-variable-buffer-local 'rng-conditional-up-to-date-end) + +(defvar rng-parsing-for-state nil + "Non-nil means we are currently parsing just to compute the state. +Should be dynamically bound.") + +(defvar rng-validate-mode nil) +(make-variable-buffer-local 'rng-validate-mode) + +(defvar rng-dtd nil) +(make-variable-buffer-local 'rng-dtd) + +;;;###autoload +(defun rng-validate-mode (&optional arg no-change-schema) + "Minor mode performing continual validation against a RELAX NG schema. + +Checks whether the buffer is a well-formed XML 1.0 document, +conforming to the XML Namespaces Recommendation and valid against a +RELAX NG schema. The mode-line indicates whether it is or not. Any +parts of the buffer that cause it not to be are considered errors and +are highlighted with `rng-error-face'. A description of each error is +available as a tooltip. \\[rng-next-error] goes to the next error +after point. Clicking mouse-1 on the word `Invalid' in the mode-line +goes to the first error in the buffer. If the buffer changes, then it +will be automatically rechecked when Emacs becomes idle; the +rechecking will be paused whenever there is input pending.. + +By default, uses a vacuous schema that allows any well-formed XML +document. A schema can be specified explictly using +\\[rng-set-schema-file-and-validate], or implicitly based on the buffer's +file name or on the root element name. In each case the schema must +be a RELAX NG schema using the compact schema \(such schemas +conventionally have a suffix of `.rnc'). The variable +`rng-schema-locating-files' specifies files containing rules +to use for finding the schema." + (interactive "P") + (setq rng-validate-mode + (if (null arg) + (not rng-validate-mode) + (> (prefix-numeric-value arg) 0))) + (save-restriction + (widen) + (nxml-with-unmodifying-text-property-changes + (rng-clear-cached-state (point-min) (point-max))) + ;; 1+ to clear empty overlays at (point-max) + (rng-clear-overlays (point-min) (1+ (point-max)))) + (setq rng-validate-up-to-date-end 1) + (rng-clear-conditional-region) + (setq rng-error-count 0) + ;; do this here to avoid infinite loop if we set the schema + (remove-hook 'rng-schema-change-hook 'rng-validate-clear t) + (cond (rng-validate-mode + (unwind-protect + (save-excursion + ;; An error can change the current buffer + (when (or (not rng-current-schema) + (and (eq rng-current-schema rng-any-element) + (not no-change-schema))) + (rng-auto-set-schema t))) + (unless rng-current-schema (rng-set-schema-file-1 nil)) + (add-hook 'rng-schema-change-hook 'rng-validate-clear nil t) + (add-hook 'after-change-functions 'rng-after-change-function nil t) + (add-hook 'kill-buffer-hook 'rng-kill-timers nil t) + (add-hook 'echo-area-clear-hook 'rng-echo-area-clear-function nil t) + (add-hook 'post-command-hook 'rng-maybe-echo-error-at-point nil t) + (rng-match-init-buffer) + (rng-activate-timers) + ;; Start validating right away if the buffer is visible. + ;; If it's not visible, don't do this, because the user + ;; won't get any progress indication. When the user finds + ;; a new file, then the buffer won't be visible + ;; when this is invoked. + (when (get-buffer-window (current-buffer) 'visible) + (rng-validate-while-idle (current-buffer))))) + (t + (rng-cancel-timers) + (force-mode-line-update) + (remove-hook 'kill-buffer-hook 'rng-cancel-timers t) + (remove-hook 'post-command-hook 'rng-maybe-echo-error-at-point t) + (remove-hook 'echo-area-clear-hook 'rng-echo-area-clear-function t) + (remove-hook 'after-change-functions 'rng-after-change-function t)))) + +(defun rng-set-schema-file-and-validate (filename) + "Sets the schema and turns on `rng-validate-mode' if not already on. +The schema is set like `rng-set-schema'." + (interactive "fSchema file: ") + (rng-set-schema-file filename) + (or rng-validate-mode (rng-validate-mode))) + +(defun rng-set-document-type-and-validate (type-id) + (interactive (list (rng-read-type-id))) + (and (rng-set-document-type type-id) + (or rng-validate-mode (rng-validate-mode)))) + +(defun rng-auto-set-schema-and-validate () + "Set the schema for this buffer automatically and turn on `rng-validate-mode'. +The schema is set like `rng-auto-set-schema'." + (interactive) + (rng-auto-set-schema) + (or rng-validate-mode (rng-validate-mode))) + +(defun rng-after-change-function (start end pre-change-len) + ;; Work around bug in insert-file-contents. + (when (> end (1+ (buffer-size))) + (setq start 1) + (setq end (1+ (buffer-size)))) + (setq rng-message-overlay-inhibit-point nil) + (nxml-with-unmodifying-text-property-changes + (rng-clear-cached-state start end)) + ;; rng-validate-up-to-date-end holds the position before the change + ;; Adjust it to reflect the change. + (if (< start rng-validate-up-to-date-end) + (setq rng-validate-up-to-date-end + (if (<= (+ start pre-change-len) rng-validate-up-to-date-end) + (+ rng-validate-up-to-date-end + (- end start pre-change-len)) + start))) + ;; Adjust the conditional zone + (cond (rng-conditional-up-to-date-start + (when (< rng-conditional-up-to-date-start end) + (if (< end rng-conditional-up-to-date-end) + (set-marker rng-conditional-up-to-date-start end) + (rng-clear-conditional-region)))) + ((< end rng-validate-up-to-date-end) + (setq rng-conditional-up-to-date-end + (copy-marker rng-validate-up-to-date-end nil)) + (setq rng-conditional-up-to-date-start + (copy-marker end t)))) + ;; Adjust rng-validate-up-to-date-end + (if (< start rng-validate-up-to-date-end) + (setq rng-validate-up-to-date-end start)) + ;; Must make rng-validate-up-to-date-end < point-max + ;; (unless the buffer is empty). + ;; otherwise validate-prepare will say there's nothing to do. + ;; Don't use (point-max) because we may be narrowed. + (if (> rng-validate-up-to-date-end (buffer-size)) + (setq rng-validate-up-to-date-end + (max 1 (1- rng-validate-up-to-date-end)))) + ;; Arrange to revalidate + (rng-activate-timers) + ;; Need to do this after activating the timer + (force-mode-line-update)) + +(defun rng-compute-mode-line-string () + (cond (rng-validate-timer + (concat " Validated:" + (number-to-string + ;; Use floor rather than round because we want + ;; to show 99% rather than 100% for changes near + ;; the end. + (floor (if (eq (buffer-size) 0) + 0.0 + (/ (* (- rng-validate-up-to-date-end 1) 100.0) + (buffer-size))))) + "%%")) + ((> rng-error-count 0) + (concat " " + (propertize "Invalid" + 'help-echo "mouse-1: go to first error" + 'local-map (make-mode-line-mouse-map + 'mouse-1 + 'rng-mouse-first-error)))) + (t " Valid"))) + +(defun rng-cancel-timers () + (let ((inhibit-quit t)) + (when rng-validate-timer + (cancel-timer rng-validate-timer) + (setq rng-validate-timer nil)) + (when rng-validate-quick-timer + (cancel-timer rng-validate-quick-timer) + (setq rng-validate-quick-timer nil)))) + +(defun rng-kill-timers () + ;; rng-validate-timer and rng-validate-quick-timer have the + ;; permanent-local property, so that the timers can be + ;; cancelled even after changing mode. + ;; This function takes care of cancelling the timers and + ;; then killing the local variables. + (when (local-variable-p 'rng-validate-timer) + (when rng-validate-timer + (cancel-timer rng-validate-timer)) + (kill-local-variable 'rng-validate-timer)) + (when (local-variable-p 'rng-validate-quick-timer) + (when rng-validate-quick-timer + (cancel-timer rng-validate-quick-timer)) + (kill-local-variable 'rng-validate-quick-timer))) + +(defun rng-activate-timers () + (unless rng-validate-timer + (let ((inhibit-quit t)) + (setq rng-validate-timer + (run-with-idle-timer rng-validate-delay + t + 'rng-validate-while-idle + (current-buffer))) + (setq rng-validate-quick-timer + (run-with-idle-timer rng-validate-quick-delay + t + 'rng-validate-quick-while-idle + (current-buffer)))))) + +(defun rng-validate-clear () + (rng-validate-mode 1 t)) + +;; These two variables are dynamically bound and used +;; to pass information between rng-validate-while-idle +;; and rng-validate-while-idle-continue-p. + +(defvar rng-validate-display-point nil) +(defvar rng-validate-display-modified-p nil) + +(defun rng-validate-while-idle-continue-p () + ;; input-pending-p and sit-for run timers that are + ;; ripe. Binding timer-idle-list to nil prevents + ;; this. If we don't do this, then any ripe timers + ;; will get run, and we won't get any chance to + ;; validate until Emacs becomes idle again or until + ;; the other lower priority timers finish (which + ;; can take a very long time in the case of + ;; jit-lock). + (let ((timer-idle-list nil)) + (and (not (input-pending-p)) + ;; Fake rng-validate-up-to-date-end so that the mode line + ;; shows progress. Also use this to save point. + (let ((rng-validate-up-to-date-end (point))) + (goto-char rng-validate-display-point) + (when (not rng-validate-display-modified-p) + (restore-buffer-modified-p nil)) + (force-mode-line-update) + (let ((continue (sit-for 0))) + (goto-char rng-validate-up-to-date-end) + continue))))) + +;; Calling rng-do-some-validation once with a continue-p function, as +;; opposed to calling it repeatedly, helps on initial validation of a +;; large buffer with lots of errors. The overlays for errors will all +;; get added when rng-do-some-validation returns and won't slow the +;; validation process down. + +(defun rng-validate-while-idle (buffer) + (with-current-buffer buffer + (if rng-validate-mode + (if (let ((rng-validate-display-point (point)) + (rng-validate-display-modified-p (buffer-modified-p))) + (rng-do-some-validation 'rng-validate-while-idle-continue-p)) + (force-mode-line-update) + (rng-validate-done)) + ;; must have done kill-all-local-variables + (rng-kill-timers)))) + +(defun rng-validate-quick-while-idle (buffer) + (with-current-buffer buffer + (if rng-validate-mode + (if (rng-do-some-validation) + (force-mode-line-update) + (rng-validate-done)) + ;; must have done kill-all-local-variables + (rng-kill-timers)))) + +(defun rng-validate-done () + (when (or (not (current-message)) + (rng-current-message-from-error-overlay-p)) + (rng-error-overlay-message (or (rng-error-overlay-after (point)) + (rng-error-overlay-after (1- (point)))))) + (rng-cancel-timers) + (force-mode-line-update)) + +(defun rng-do-some-validation (&optional continue-p-function) + "Do some validation work. Return t if more to do, nil otherwise." + (save-excursion + (save-restriction + (widen) + (nxml-with-invisible-motion + (condition-case err + (and (rng-validate-prepare) + (let ((rng-dt-namespace-context-getter '(nxml-ns-get-context))) + (nxml-with-unmodifying-text-property-changes + (rng-do-some-validation-1 continue-p-function)))) + ;; errors signalled from a function run by an idle timer + ;; are ignored; if we don't catch them, validation + ;; will get mysteriously stuck at a single place + (rng-compile-error + (message "Incorrect schema. %s" (nth 1 err)) + (rng-validate-mode 0) + nil) + (error + (message "Internal error in rng-validate-mode triggered at buffer position %d. %s" + (point) + (error-message-string err)) + (rng-validate-mode 0) + nil)))))) + +(defun rng-validate-prepare () + "Prepare to do some validation, initializing point and the state. +Return t if there is work to do, nil otherwise." + (cond ((= rng-validate-up-to-date-end (point-min)) + (rng-set-initial-state) + t) + ((= rng-validate-up-to-date-end (point-max)) + nil) + (t (let ((state (get-text-property (1- rng-validate-up-to-date-end) + 'rng-state))) + (cond (state + (rng-restore-state state) + (goto-char rng-validate-up-to-date-end)) + (t + (let ((pos (previous-single-property-change + rng-validate-up-to-date-end + 'rng-state))) + (cond (pos + (rng-restore-state + (or (get-text-property (1- pos) 'rng-state) + (error "Internal error: state null"))) + (goto-char pos)) + (t (rng-set-initial-state)))))))))) + + +(defun rng-do-some-validation-1 (&optional continue-p-function) + (let ((limit (+ rng-validate-up-to-date-end + rng-validate-chunk-size)) + (remove-start rng-validate-up-to-date-end) + (next-cache-point (+ (point) rng-state-cache-distance)) + (continue t) + (xmltok-dtd rng-dtd) + have-remaining-chars + xmltok-type + xmltok-start + xmltok-name-colon + xmltok-name-end + xmltok-replacement + xmltok-attributes + xmltok-namespace-attributes + xmltok-dependent-regions + xmltok-errors) + (when (= (point) 1) + (let ((regions (xmltok-forward-prolog))) + (rng-clear-overlays 1 (point)) + (while regions + (when (eq (aref (car regions) 0) 'encoding-name) + (rng-process-encoding-name (aref (car regions) 1) + (aref (car regions) 2))) + (setq regions (cdr regions)))) + (unless (equal rng-dtd xmltok-dtd) + (rng-clear-conditional-region)) + (setq rng-dtd xmltok-dtd)) + (while continue + (setq have-remaining-chars (rng-forward)) + (let ((pos (point))) + (setq continue + (and have-remaining-chars + (or (< pos limit) + (and continue-p-function + (funcall continue-p-function) + (setq limit (+ limit rng-validate-chunk-size)) + t)))) + (cond ((and rng-conditional-up-to-date-start + ;; > because we are getting the state from (1- pos) + (> pos rng-conditional-up-to-date-start) + (< pos rng-conditional-up-to-date-end) + (rng-state-matches-current (get-text-property (1- pos) + 'rng-state))) + (when (< remove-start (1- pos)) + (rng-clear-cached-state remove-start (1- pos))) + ;; sync up with cached validation state + (setq continue nil) + ;; do this before settting rng-validate-up-to-date-end + ;; in case we get a quit + (rng-mark-xmltok-errors) + (rng-mark-xmltok-dependent-regions) + (setq rng-validate-up-to-date-end + (marker-position rng-conditional-up-to-date-end)) + (rng-clear-conditional-region) + (setq have-remaining-chars + (< rng-validate-up-to-date-end (point-max)))) + ((or (>= pos next-cache-point) + (not continue)) + (setq next-cache-point (+ pos rng-state-cache-distance)) + (rng-clear-cached-state remove-start pos) + (when have-remaining-chars + (rng-cache-state (1- pos))) + (setq remove-start pos) + (unless continue + ;; if we have just blank chars skip to the end + (when have-remaining-chars + (skip-chars-forward " \t\r\n") + (when (= (point) (point-max)) + (rng-clear-overlays pos (point)) + (rng-clear-cached-state pos (point)) + (setq have-remaining-chars nil) + (setq pos (point)))) + (when (not have-remaining-chars) + (rng-process-end-document)) + (rng-mark-xmltok-errors) + (rng-mark-xmltok-dependent-regions) + (setq rng-validate-up-to-date-end pos) + (when rng-conditional-up-to-date-end + (cond ((<= rng-conditional-up-to-date-end pos) + (rng-clear-conditional-region)) + ((< rng-conditional-up-to-date-start pos) + (set-marker rng-conditional-up-to-date-start + pos))))))))) + have-remaining-chars)) + +(defun rng-clear-conditional-region () + (when rng-conditional-up-to-date-start + (set-marker rng-conditional-up-to-date-start nil) + (setq rng-conditional-up-to-date-start nil)) + (when rng-conditional-up-to-date-end + (set-marker rng-conditional-up-to-date-end nil) + (setq rng-conditional-up-to-date-end nil))) + +(defun rng-clear-cached-state (start end) + "Clear cached state between START and END." + (remove-text-properties start end '(rng-state nil))) + +(defun rng-cache-state (pos) + "Save the current state in a text property on the character at pos." + (put-text-property pos + (1+ pos) + 'rng-state + (rng-get-state))) + +(defun rng-state-matches-current (state) + (and state + (rng-match-state-equal (car state)) + (nxml-ns-state-equal (nth 1 state)) + (equal (nth 2 state) rng-open-elements))) + +(defun rng-get-state () + (list (rng-match-state) + (nxml-ns-state) + rng-open-elements)) + +(defun rng-restore-state (state) + (rng-set-match-state (car state)) + (setq state (cdr state)) + (nxml-ns-set-state (car state)) + (setq rng-open-elements (cadr state)) + (setq rng-pending-contents nil) + (setq rng-collecting-text (rng-match-text-typed-p))) + +(defun rng-set-initial-state () + (nxml-ns-init) + (rng-match-start-document) + (setq rng-open-elements nil) + (setq rng-pending-contents nil) + (goto-char (point-min))) + +(defun rng-clear-overlays (beg end) + (unless rng-parsing-for-state + (let ((overlays (overlays-in beg end))) + (while overlays + (let* ((overlay (car overlays)) + (category (overlay-get overlay 'category))) + (cond ((eq category 'rng-error) + (let ((inhibit-quit t)) + (when (eq overlay rng-message-overlay) + (rng-error-overlay-message nil)) + (delete-overlay overlay) + ;; rng-error-count could be nil + ;; if overlays left over from a previous use + ;; of rng-validate-mode that ended with a change of mode + (when rng-error-count + (setq rng-error-count (1- rng-error-count))))) + ((and (eq category 'rng-dependent) + (<= beg (overlay-start overlay))) + (delete-overlay overlay)))) + (setq overlays (cdr overlays)))))) + +;;; Dependent regions + +(defun rng-mark-xmltok-dependent-regions () + (while xmltok-dependent-regions + (apply 'rng-mark-xmltok-dependent-region + (car xmltok-dependent-regions)) + (setq xmltok-dependent-regions + (cdr xmltok-dependent-regions)))) + +(defun rng-mark-xmltok-dependent-region (fun start end &rest args) + (let ((overlay (make-overlay start end nil t t))) + (overlay-put overlay 'category 'rng-dependent) + (overlay-put overlay 'rng-funargs (cons fun args)))) + +(put 'rng-dependent 'evaporate t) +(put 'rng-dependent 'modification-hooks '(rng-dependent-region-changed)) +(put 'rng-dependent 'insert-behind-hooks '(rng-dependent-region-changed)) + +(defun rng-dependent-region-changed (overlay + after-p + change-start + change-end + &optional pre-change-length) + (when (and after-p + ;; Emacs sometimes appears to call deleted overlays + (overlay-start overlay) + (let ((funargs (overlay-get overlay 'rng-funargs))) + (save-match-data + (save-excursion + (save-restriction + (widen) + (apply (car funargs) + (append (list change-start + change-end + pre-change-length + (overlay-start overlay) + (overlay-end overlay)) + (cdr funargs)))))))) + (rng-after-change-function (overlay-start overlay) + change-end + (+ pre-change-length + (- (overlay-start overlay) + change-start))) + (delete-overlay overlay))) + +;;; Error state + +(defun rng-mark-xmltok-errors () + (while xmltok-errors + (let ((err (car xmltok-errors))) + (rng-mark-not-well-formed (xmltok-error-message err) + (xmltok-error-start err) + (xmltok-error-end err))) + (setq xmltok-errors (cdr xmltok-errors)))) + +(defun rng-mark-invalid (message beg end) + (rng-mark-error message beg end)) + +(defun rng-mark-not-well-formed (message beg end) + ;; Don't try to validate further + ;;(rng-set-match-state rng-not-allowed-ipattern) + (rng-mark-error message beg end)) + +(defun rng-mark-error (message beg end) + (unless rng-parsing-for-state + (let ((overlays (overlays-in beg end))) + (while (and overlays message) + (let ((o (car overlays))) + (when (and (eq (overlay-get o 'category) 'rng-error) + (= (overlay-start o) beg) + (= (overlay-end o) end)) + (overlay-put o + 'help-echo + (concat (overlay-get o 'help-echo) + "\n" + message)) + (setq message nil))) + (setq overlays (cdr overlays)))) + (when message + (let ((inhibit-quit t)) + (setq rng-error-count (1+ rng-error-count)) + (let ((overlay + (make-overlay beg end nil t + ;; Need to make the rear delimiter advance + ;; with the front delimiter when the overlay + ;; is empty, otherwise the front delimiter + ;; will move past the rear delimiter. + (= beg end)))) + ;; Ensure when we have two overlapping messages, the help-echo + ;; of the one that starts first is shown + (overlay-put overlay 'priority beg) + (overlay-put overlay 'category 'rng-error) + (overlay-put overlay 'help-echo message)))))) + +(put 'rng-error 'face 'rng-error-face) +(put 'rng-error 'modification-hooks '(rng-error-modified)) + +;; If we don't do this, then the front delimiter can move +;; past the end delimiter. +(defun rng-error-modified (overlay after-p beg end &optional pre-change-len) + (when (and after-p + (overlay-start overlay) ; check not deleted + (>= (overlay-start overlay) + (overlay-end overlay))) + (let ((inhibit-quit t)) + (delete-overlay overlay) + (setq rng-error-count (1- rng-error-count))))) + +(defun rng-echo-area-clear-function () + (setq rng-message-overlay-current nil)) + +;;; Error navigation + +(defun rng-maybe-echo-error-at-point () + (when (or (not (current-message)) + (rng-current-message-from-error-overlay-p)) + (rng-error-overlay-message (rng-error-overlay-after (point))))) + +(defun rng-error-overlay-after (pos) + (let ((overlays (overlays-in pos (1+ pos))) + (best nil)) + (while overlays + (let ((overlay (car overlays))) + (when (and (eq (overlay-get overlay 'category) + 'rng-error) + (or (not best) + (< (overlay-start best) + (overlay-start overlay)))) + (setq best overlay))) + (setq overlays (cdr overlays))) + best)) + +(defun rng-first-error () + "Go to the first validation error. +Turn on `rng-validate-mode' if it is not already on." + (interactive) + (or rng-validate-mode (rng-validate-mode)) + (when (and (eq rng-validate-up-to-date-end 1) + (< rng-validate-up-to-date-end (point-max))) + (rng-do-some-validation)) + (let ((err (rng-find-next-error-overlay (1- (point-min))))) + (if err + (rng-goto-error-overlay err) + (let ((pos (save-excursion + (goto-char (point-min)) + (rng-next-error 1)))) + (when pos + (goto-char pos)))))) + +(defun rng-mouse-first-error (event) + "Go to the first validation error from a mouse click." + (interactive "e") + (select-window (posn-window (event-start event))) + (rng-first-error)) + +(defun rng-next-error (arg) + "Go to the next validation error after point. +Turn on `rng-validate-mode' if it is not already on. +A prefix ARG specifies how many errors to move. A negative ARG +moves backwards. Just \\[universal-argument] as a prefix +means goto the first error." + (interactive "P") + (if (consp arg) + (rng-first-error) + (or rng-validate-mode (rng-validate-mode)) + (setq arg (prefix-numeric-value arg)) + (if (< arg 0) + (rng-previous-error-1 (- arg)) + (rng-next-error-1 arg)))) + +(defun rng-previous-error (arg) + "Go to the previous validation error before point. +Turn on `rng-validate-mode' if it is not already on. +A prefix ARG specifies how many errors to move. A negative ARG +moves forwards. Just \\[universal-argument] as a prefix +means goto the first error." + (interactive "P") + (if (consp arg) + (rng-first-error) + (or rng-validate-mode (rng-validate-mode)) + (setq arg (prefix-numeric-value arg)) + (if (< arg 0) + (rng-next-error-1 (- arg)) + (rng-previous-error-1 arg)))) + +(defun rng-next-error-1 (arg) + (let* ((pos (point)) + err last-err) + (while (and (> arg 0) + (setq err (rng-find-next-error-overlay pos))) + (setq arg (1- arg)) + (setq last-err err) + (setq pos (overlay-start err))) + (when (> arg 0) + (setq pos (max pos (1- rng-validate-up-to-date-end))) + (when (< rng-validate-up-to-date-end (point-max)) + (message "Parsing...") + (while (let ((more-to-do (rng-do-some-validation))) + (while (and (> arg 0) + (setq err (rng-find-next-error-overlay pos))) + (setq arg (1- arg)) + (setq last-err err) + (setq pos (overlay-start err))) + (when (and (> arg 0) + more-to-do + (< rng-validate-up-to-date-end (point-max))) + ;; Display percentage validated. + (force-mode-line-update) + ;; Force redisplay but don't allow idle timers to run. + (let ((timer-idle-list nil)) + (sit-for 0)) + (setq pos + (max pos (1- rng-validate-up-to-date-end))) + t))))) + (if last-err + (rng-goto-error-overlay last-err) + (message "No more errors") + nil))) + +(defun rng-previous-error-1 (arg) + (let* ((pos (point)) + err last-err) + (while (and (> arg 0) + (setq err (rng-find-previous-error-overlay pos))) + (setq pos (overlay-start err)) + (setq last-err err) + (setq arg (1- arg))) + (when (and (> arg 0) + (< rng-validate-up-to-date-end (min pos (point-max)))) + (message "Parsing...") + (while (and (rng-do-some-validation) + (< rng-validate-up-to-date-end (min pos (point-max)))) + (force-mode-line-update) + ;; Force redisplay but don't allow idle timers to run. + (let ((timer-idle-list nil)) + (sit-for 0))) + (while (and (> arg 0) + (setq err (rng-find-previous-error-overlay pos))) + (setq pos (overlay-start err)) + (setq last-err err) + (setq arg (1- arg)))) + (if last-err + (rng-goto-error-overlay last-err) + (message "No previous errors") + nil))) + +(defun rng-goto-error-overlay (err) + "Goto the start of error overlay ERR and print its message." + (goto-char (overlay-start err)) + (setq rng-message-overlay-inhibit-point nil) + (rng-error-overlay-message err)) + +(defun rng-error-overlay-message (err) + (if err + (unless (or (and (eq rng-message-overlay-inhibit-point (point)) + (eq rng-message-overlay err)) + (= (point-max) 1)) + (message "%s" (overlay-get err 'help-echo)) + (setq rng-message-overlay-current t) + (setq rng-message-overlay-inhibit-point (point))) + (when (rng-current-message-from-error-overlay-p) + (message nil)) + (setq rng-message-overlay-inhibit-point nil)) + (setq rng-message-overlay err)) + +(defun rng-current-message-from-error-overlay-p () + (and rng-message-overlay-current + rng-message-overlay + (equal (overlay-get rng-message-overlay 'help-echo) + (current-message)))) + +(defun rng-find-next-error-overlay (pos) + "Return the overlay for the next error starting after POS. +Return nil if there is no such overlay or it is out of date. +Do not do any additional validation." + (when rng-error-count + (let (done found overlays) + (while (not done) + (cond (overlays + (let ((overlay (car overlays))) + (setq overlays (cdr overlays)) + (when (and (eq (overlay-get overlay 'category) 'rng-error) + ;; Is it the first? + (= (overlay-start overlay) pos) + ;; Is it up to date? + (<= (overlay-end overlay) + rng-validate-up-to-date-end)) + (setq done t) + (setq found overlay)))) + ((or (= pos (point-max)) + (> (setq pos (next-overlay-change pos)) + rng-validate-up-to-date-end)) + (setq done t)) + (t (setq overlays (overlays-in pos (1+ pos)))))) + found))) + +(defun rng-find-previous-error-overlay (pos) + "Return the overlay for the last error starting before POS. +Return nil if there is no such overlay or it is out of date. +Do not do any additional validation." + (when (and rng-error-count + (<= pos rng-validate-up-to-date-end)) + (let (done found overlays) + (while (not done) + (cond (overlays + (let ((overlay (car overlays))) + (setq overlays (cdr overlays)) + (when (and (eq (overlay-get overlay 'category) 'rng-error) + ;; Is it the first? + (= (overlay-start overlay) pos)) + (setq done t) + (setq found overlay)))) + ((= pos (point-min)) + (setq done t)) + (t + (setq pos (previous-overlay-change pos)) + (setq overlays (overlays-in pos (1+ pos)))))) + found))) + +;;; Parsing + +(defun rng-forward (&optional limit) + "Move forward over one or more tokens updating the state. +If LIMIT is nil, stop after tags. +If LIMIT is non-nil, stop when end of last token parsed is >= LIMIT. +Return nil at end of buffer, t otherwise." + (let (type) + (while (progn + (setq type (xmltok-forward)) + (rng-clear-overlays xmltok-start (point)) + (let ((continue + (cond ((eq type 'start-tag) + (rng-process-start-tag 'start-tag) + nil) + ((eq type 'end-tag) + (rng-process-end-tag) + nil) + ((eq type 'empty-element) + (rng-process-start-tag 'empty-element) + nil) + ((eq type 'space) + (rng-process-text xmltok-start nil t) + t) + ((eq type 'data) + (rng-process-text xmltok-start nil nil) + t) + ((memq type '(entity-ref char-ref)) + (cond (xmltok-replacement + (rng-process-text xmltok-start + nil + 'maybe + xmltok-replacement)) + ((eq type 'char-ref) + (rng-process-unknown-char)) + (t + (rng-process-unknown-entity))) + t) + ((eq type 'cdata-section) + (rng-process-text (+ xmltok-start 9) ; "<![CDATA[" + (- (point) 3) ; "]]>" + 'maybe) + t) + ((eq type 'partial-start-tag) + (rng-process-start-tag 'partial-start-tag) + t) + ((eq type 'partial-empty-element) + (rng-process-start-tag 'empty-element) + t) + ((eq type 'partial-end-tag) + (rng-process-end-tag 'partial) + t) + (t type)))) + (if limit + (< (point) limit) + continue)))) + (and type t))) + +(defun rng-process-start-tag (tag-type) + "TAG-TYPE is `start-tag' for a start-tag, `empty-element' for +an empty element. partial-empty-element should be passed +as empty-element." + (and rng-collecting-text (rng-flush-text)) + (setq rng-collecting-text nil) + (setq rng-pending-contents nil) + (rng-process-namespaces) + (let ((tag (rng-process-tag-name))) + (rng-process-attributes) + ;; set the state appropriately + (cond ((eq tag-type 'empty-element) + (rng-process-start-tag-close) + ;; deal with missing content with empty element + (when (not (rng-match-empty-content)) + (rng-match-after) + (rng-mark-start-tag-close "Empty content not allowed")) + (nxml-ns-pop-state)) + ((eq tag-type 'start-tag) + (rng-process-start-tag-close) + (setq rng-collecting-text (rng-match-text-typed-p)) + (rng-push-tag tag)) + ((eq tag-type 'partial-start-tag) + (rng-process-start-tag-close) + (rng-match-after) + (nxml-ns-pop-state))))) + +(defun rng-process-namespaces () + (let ((nsatts xmltok-namespace-attributes) + prefixes) + (nxml-ns-push-state) + (while nsatts + (let* ((att (car nsatts)) + (value (xmltok-attribute-value att))) + (when value + (let ((ns (nxml-make-namespace value)) + (prefix (and (xmltok-attribute-prefix att) + (xmltok-attribute-local-name att)))) + (cond ((member prefix prefixes) + (rng-mark-invalid "Duplicate namespace declaration" + (xmltok-attribute-name-start att) + (xmltok-attribute-name-end att))) + ((not prefix) + (nxml-ns-set-default ns)) + (ns + (nxml-ns-set-prefix prefix ns)) + (t + ;; cannot have xmlns:foo="" + (rng-mark-invalid "Namespace prefix cannot be undeclared" + (1- (xmltok-attribute-value-start att)) + (1+ (xmltok-attribute-value-end att))))) + (setq prefixes (cons prefix prefixes))))) + (setq nsatts (cdr nsatts))))) + +(defun rng-process-tag-name () + (let* ((prefix (xmltok-start-tag-prefix)) + (local-name (xmltok-start-tag-local-name)) + (name + (if prefix + (let ((ns (nxml-ns-get-prefix prefix))) + (cond (ns (cons ns local-name)) + ((and (setq ns + (rng-match-infer-start-tag-namespace + local-name)) + (rng-match-start-tag-open (cons ns local-name))) + (nxml-ns-set-prefix prefix ns) + (rng-mark-start-tag-close "Missing xmlns:%s=\"%s\"" + prefix + (nxml-namespace-name ns)) + nil) + (t + (rng-recover-bad-element-prefix) + nil))) + (cons (nxml-ns-get-default) local-name)))) + (when (and name + (not (rng-match-start-tag-open name))) + (unless (and (not (car name)) + (let ((ns (rng-match-infer-start-tag-namespace (cdr name)))) + (and ns + (rng-match-start-tag-open (cons ns local-name)) + (progn + (nxml-ns-set-default ns) + ;; XXX need to check we don't have xmlns="" + (rng-mark-start-tag-close "Missing xmlns=\"%s\"" + (nxml-namespace-name ns)) + t)))) + (rng-recover-start-tag-open name))) + (cons prefix local-name))) + +(defun rng-process-attributes () + (let ((atts xmltok-attributes) + names) + (while atts + (let* ((att (car atts)) + (prefix (xmltok-attribute-prefix att)) + (local-name (xmltok-attribute-local-name att)) + (name + (if prefix + (let ((ns (nxml-ns-get-prefix prefix))) + (and ns + (cons ns local-name))) + (cons nil local-name)))) + (cond ((not name) + (rng-recover-bad-attribute-prefix att)) + ((member name names) + (rng-recover-duplicate-attribute-name att)) + ((not (rng-match-attribute-name name)) + (rng-recover-attribute-name att)) + ((rng-match-text-typed-p) + (let ((value (xmltok-attribute-value att))) + (if value + (or (rng-match-attribute-value value) + (rng-recover-attribute-value att)) + (rng-match-after)))) + (t (or (rng-match-end-tag) + (error "Internal error:\ + invalid on untyped attribute value")))) + (setq names (cons name names))) + (setq atts (cdr atts))))) + +(defun rng-process-start-tag-close () + ;; deal with missing attributes + (unless (rng-match-start-tag-close) + (rng-mark-start-tag-close (rng-missing-attributes-message)) + (rng-match-ignore-attributes))) + +(defun rng-mark-start-tag-close (&rest args) + (when (not (eq xmltok-type 'partial-start-tag)) + (rng-mark-invalid (apply 'format args) + (- (point) + (if (eq xmltok-type 'empty-element) + 2 + 1)) + (point)))) + +(defun rng-recover-bad-element-prefix () + (rng-mark-invalid "Prefix not declared" + (1+ xmltok-start) + xmltok-name-colon) + (rng-match-unknown-start-tag-open)) + +(defun rng-recover-bad-attribute-prefix (att) + (rng-mark-invalid "Prefix not declared" + (xmltok-attribute-name-start att) + (xmltok-attribute-name-colon att))) + +(defun rng-recover-duplicate-attribute-name (att) + (rng-mark-invalid "Duplicate attribute" + (xmltok-attribute-name-start att) + (xmltok-attribute-name-end att))) + +(defun rng-recover-start-tag-open (name) + (let ((required (rng-match-required-element-name))) + (cond ((and required + (rng-match-start-tag-open required) + (rng-match-after) + (rng-match-start-tag-open name)) + (rng-mark-invalid (concat "Missing element " + (rng-quote-string + (rng-name-to-string required))) + xmltok-start + (1+ xmltok-start))) + ((and (rng-match-optionalize-elements) + (rng-match-start-tag-open name)) + (rng-mark-invalid "Required elements missing" + xmltok-start + (1+ xmltok-start))) + ((rng-match-out-of-context-start-tag-open name) + (rng-mark-invalid "Element not allowed in this context" + (1+ xmltok-start) + xmltok-name-end)) + (t + (rng-match-unknown-start-tag-open) + (rng-mark-invalid "Unknown element" + (1+ xmltok-start) + xmltok-name-end))))) + +(defun rng-recover-attribute-value (att) + (let ((start (xmltok-attribute-value-start att)) + (end (xmltok-attribute-value-end att))) + (if (= start end) + (rng-mark-invalid "Empty attribute value invalid" start (1+ end)) + (rng-mark-invalid "Attribute value invalid" start end))) + (rng-match-after)) + +(defun rng-recover-attribute-name (att) + (rng-mark-invalid "Attribute not allowed" + (xmltok-attribute-name-start att) + (xmltok-attribute-name-end att))) + +(defun rng-missing-attributes-message () + (let ((required-attributes + (rng-match-required-attribute-names))) + (cond ((not required-attributes) + "Required attributes missing") + ((not (cdr required-attributes)) + (concat "Missing attribute " + (rng-quote-string + (rng-name-to-string (car required-attributes) t)))) + (t + (concat "Missing attributes " + (mapconcat (lambda (nm) + (rng-quote-string + (rng-name-to-string nm t))) + required-attributes + ", ")))))) + +(defun rng-process-end-tag (&optional partial) + (cond ((not rng-open-elements) + (rng-mark-not-well-formed "Extra end-tag" + xmltok-start + (point))) + ((or partial + (equal (cons (xmltok-end-tag-prefix) + (xmltok-end-tag-local-name)) + (car rng-open-elements))) + (rng-end-element)) + (t (rng-recover-mismatched-end-tag)))) + +(defun rng-end-element () + (if rng-collecting-text + (let ((contents (rng-contents-string))) + (cond ((not contents) (rng-match-after)) + ((not (rng-match-element-value contents)) + (let* ((region (rng-contents-region))) + (if (not region) + (rng-mark-invalid "Empty content not allowed" + xmltok-start + (+ xmltok-start 2)) + (rng-mark-invalid "Invalid data" + (car region) + (cdr region)))) + (rng-match-after))) + (setq rng-collecting-text nil) + (setq rng-pending-contents nil)) + (unless (rng-match-end-tag) + (rng-mark-invalid (rng-missing-element-message) + xmltok-start + (+ xmltok-start 2)) + (rng-match-after))) + (nxml-ns-pop-state) + (when (eq (car rng-open-elements) t) + (rng-pop-tag)) + (rng-pop-tag)) + +(defun rng-missing-element-message () + (let ((element (rng-match-required-element-name))) + (if element + (concat "Missing element " + (rng-quote-string (rng-name-to-string element))) + "Required child elements missing"))) + +(defun rng-recover-mismatched-end-tag () + (let* ((name (cons (xmltok-end-tag-prefix) + (xmltok-end-tag-local-name)))) + (cond ((member name (cdr rng-open-elements)) + (let* ((suppress-error (eq (car rng-open-elements) t)) + missing top) + (while (progn + (setq top (car rng-open-elements)) + (rng-pop-tag) + (unless (eq top t) + (setq missing (cons top missing)) + (nxml-ns-pop-state) + (rng-match-after)) + (not (equal top name)))) + (unless suppress-error + (rng-mark-missing-end-tags (cdr missing))))) + ((rng-match-empty-before-p) + (rng-mark-mismatched-end-tag) + (rng-end-element)) + (t (rng-mark-mismatched-end-tag) + (setq rng-open-elements + (cons t rng-open-elements)))))) + +(defun rng-mark-missing-end-tags (missing) + (rng-mark-not-well-formed + (format "Missing end-tag%s %s" + (if (null (cdr missing)) "" "s") + (mapconcat (lambda (name) + (rng-quote-string + (if (car name) + (concat (car name) + ":" + (cdr name)) + (cdr name)))) + missing + ", ")) + xmltok-start + (+ xmltok-start 2))) + +(defun rng-mark-mismatched-end-tag () + (rng-mark-not-well-formed "Mismatched end-tag" + (+ xmltok-start 2) + xmltok-name-end)) + +(defun rng-push-tag (prefix-local-name) + (setq rng-open-elements + (cons prefix-local-name rng-open-elements))) + +(defun rng-pop-tag () + (setq rng-open-elements (cdr rng-open-elements))) + +(defun rng-contents-string () + (let ((contents rng-pending-contents)) + (cond ((not contents) "") + ((memq nil contents) nil) + ((not (cdr contents)) + (rng-segment-string (car contents))) + (t (apply 'concat + (nreverse (mapcar 'rng-segment-string + contents))))))) + +(defun rng-segment-string (segment) + (or (car segment) + (apply 'buffer-substring-no-properties + (cdr segment)))) + +(defun rng-segment-blank-p (segment) + (if (car segment) + (rng-blank-p (car segment)) + (apply 'rng-region-blank-p + (cdr segment)))) + +(defun rng-contents-region () + (if (null rng-pending-contents) + nil + (let* ((contents rng-pending-contents) + (head (cdar contents)) + (start (car head)) + (end (cadr head))) + (while (setq contents (cdr contents)) + (setq start (car (cdar contents)))) + (cons start end)))) + +(defun rng-process-text (start end whitespace &optional value) + "Process characters between position START and END as text. +END nil means point. WHITESPACE t means known to be whitespace, nil +means known not to be, anything else means unknown whether whitespace +or not. END must not be nil if WHITESPACE is neither t nor nil. +VALUE is a string or nil; nil means the value is equal to the +string between START and END." + (cond (rng-collecting-text + (setq rng-pending-contents (cons (list value start (or end (point))) + rng-pending-contents))) + ((not (or (and whitespace + (or (eq whitespace t) + (if value + (rng-blank-p value) + (rng-region-blank-p start end)))) + (rng-match-mixed-text))) + (rng-mark-invalid "Text not allowed" start (or end (point)))))) + +(defun rng-process-unknown-char () + (when rng-collecting-text + (setq rng-pending-contents + (cons nil rng-pending-contents)))) + +(defun rng-process-unknown-entity () + (rng-process-unknown-char) + (rng-match-optionalize-elements)) + +(defun rng-region-blank-p (beg end) + (save-excursion + (goto-char beg) + (= (skip-chars-forward " \n\r\t" end) + (- end beg)))) + +(defun rng-flush-text () + (while rng-pending-contents + (let ((segment (car rng-pending-contents))) + (unless (or (rng-segment-blank-p segment) + (rng-match-mixed-text)) + (let ((region (cdr segment))) + (rng-mark-invalid "In this context text cannot be mixed with elements" + (car region) + (cadr region))))) + (setq rng-pending-contents (cdr rng-pending-contents)))) + +(defun rng-process-end-document () + ;; this is necessary to clear empty overlays at (point-max) + (rng-clear-overlays (point) (point)) + (let ((start (save-excursion + (skip-chars-backward " \t\r\n") + (point)))) + (cond (rng-open-elements + (unless (eq (car rng-open-elements) t) + (rng-mark-not-well-formed "Missing end-tag" + start + (point)))) + ((not (rng-match-nullable-p)) + (rng-mark-not-well-formed "No document element" + start + (point)))))) + +(defun rng-process-encoding-name (beg end) + (unless (let ((charset (buffer-substring-no-properties beg end))) + (or (nxml-mime-charset-coding-system charset) + (string= (downcase charset) "utf-16"))) + (rng-mark-not-well-formed "Unsupported encoding" beg end))) + +(defun rng-name-to-string (name &optional attributep) + (let ((ns (car name)) + (local-name (cdr name))) + (if (or (not ns) + (and (not attributep) + (eq (nxml-ns-get-default) ns))) + local-name + (let ((prefix (nxml-ns-prefix-for ns))) + (if prefix + (concat prefix ":" local-name) + (concat "{" (symbol-name ns) "}" local-name)))))) + +(provide 'rng-valid) + +;; arch-tag: 7dd846d3-519d-4a6d-8107-4ff0024a60ef +;;; rng-valid.el ends here diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el new file mode 100644 index 00000000000..782627c4205 --- /dev/null +++ b/lisp/nxml/rng-xsd.el @@ -0,0 +1,861 @@ +;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, RelaxNG + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; The main entry point is `rng-xsd-compile'. The validator +;; knows to use this for the datatype library with URI +;; http://www.w3.org/2001/XMLSchema-datatypes because it +;; is the value of the rng-dt-compile property on that URI +;; as a symbol. +;; +;; W3C XML Schema Datatypes are specified by +;; http://www.w3.org/TR/xmlschema-2/ +;; Guidelines for using them with RELAX NG are described in +;; http://relaxng.org/xsd.html + +;;; Code: + +(require 'rng-dt) +(require 'rng-util) +(require 'xsd-regexp) + +;;;###autoload +(put 'http://www.w3.org/2001/XMLSchema-datatypes + 'rng-dt-compile + 'rng-xsd-compile) + +;;;###autoload +(defun rng-xsd-compile (name params) + "Provides W3C XML Schema as a RELAX NG datatypes library. NAME is a +symbol giving the local name of the datatype. PARAMS is a list of +pairs (PARAM-NAME . PARAM-VALUE) where PARAM-NAME is a symbol giving +the name of the parameter and PARAM-VALUE is a string giving its +value. If NAME or PARAMS are invalid, it calls rng-dt-error passing +it arguments in the same style as format; the value from rng-dt-error +will be returned. Otherwise, it returns a list. The first member of +the list is t if any string is a legal value for the datatype and nil +otherwise. The second argument is a symbol; this symbol will be +called as a function passing it a string followed by the remaining +members of the list. The function must return an object representing +the value of the datatype that was represented by the string, or nil +if the string is not a representation of any value. The object +returned can be any convenient non-nil value, provided that, if two +strings represent the same value, the returned objects must be equal." + (let ((convert (get name 'rng-xsd-convert))) + (if (not convert) + (rng-dt-error "There is no XSD datatype named %s" name) + (rng-xsd-compile1 name params convert)))) + +;;; Parameters + +(defun rng-xsd-compile1 (name params convert) + (if (null params) + (cons (equal convert '(identity)) + (cond ((eq name 'string) convert) + ((eq name 'normalizedString) + (cons 'rng-xsd-replace-space convert)) + ((and (not (eq name 'string)) + (or (memq 'identity convert) + (memq 'rng-xsd-convert-any-uri convert) + (memq 'rng-xsd-check-pattern convert))) + (cons 'rng-xsd-collapse-space convert)) + (t convert))) + (let* ((param (car params)) + (param-name (car param)) + (param-value (cdr param))) + (cond ((memq param-name + '(minExclusive maxExclusive minInclusive maxInclusive)) + (let ((limit (apply (car convert) + (cons param-value + (cdr convert)))) + (less-than-fun (get name 'rng-xsd-less-than))) + (cond ((not limit) + (rng-dt-error "Minimum value %s is not valid" + param-value)) + ((not less-than-fun) + (rng-dt-error "Values of type %s are not ordered" + param-name)) + (t + (rng-xsd-compile1 name + (cdr params) + (cons (get param-name + 'rng-xsd-check) + (cons less-than-fun + (cons limit convert)))))))) + ((memq param-name '(length minLength maxLength)) + (let ((limit (rng-xsd-string-to-non-negative-integer param-value)) + (length-fun (get name 'rng-xsd-length))) + (cond ((not limit) + (rng-dt-error "Length %s is not valid" param-value)) + ((not length-fun) + (rng-dt-error "Values of type %s do not have a length" + param-name)) + (t + (rng-xsd-compile1 name + (cdr params) + (cons (get param-name + 'rng-xsd-check) + (cons length-fun + (cons limit convert)))))))) + ((memq param-name '(fractionDigits totalDigits)) + (let ((n (rng-xsd-string-to-non-negative-integer param-value))) + (cond ((not n) + (rng-dt-error "Number of digits %s is not valid" + param-value)) + (t + (rng-xsd-compile1 name + (cdr params) + (cons (get param-name + 'rng-xsd-check) + (cons n convert))))))) + ((eq param-name 'pattern) + (condition-case err + (rng-xsd-compile1 name + (cdr params) + (cons 'rng-xsd-check-pattern + (cons (concat + "\\`" + (xsdre-translate param-value) + "\\'") + convert))) + (xsdre-invalid-regexp + (rng-dt-error "Invalid regular expression (%s)" + (nth 1 err))))) + ((memq param-name '(enumeration whiteSpace)) + (rng-dt-error "Facet %s cannot be used in RELAX NG" param-name)) + (t (rng-dt-error "Unknown facet %s" param-name)))))) + +(defun rng-xsd-string-to-non-negative-integer (str) + (and (rng-xsd-convert-integer str) + (let ((n (string-to-number str))) + (and (integerp n) + (>= n 0) + n)))) + +(defun rng-xsd-collapse-space (str convert &rest args) + (apply convert (cons (mapconcat 'identity (split-string str "[ \t\n\r]+") + " ") + args))) + +(defun rng-xsd-replace-space (str convert &rest args) + (apply convert + (cons (let ((i 0) + copied) + (while (and (setq i (string-match "[\r\n\t]" str i)) + (or copied (setq copied (copy-sequence str))) + (aset copied i 32) + (setq i (1+ i)))) + (or copied str)) + args))) + +(put 'minExclusive 'rng-xsd-check 'rng-xsd-check-min-exclusive) +(put 'minInclusive 'rng-xsd-check 'rng-xsd-check-min-inclusive) +(put 'maxExclusive 'rng-xsd-check 'rng-xsd-check-max-exclusive) +(put 'maxInclusive 'rng-xsd-check 'rng-xsd-check-max-inclusive) +(put 'length 'rng-xsd-check 'rng-xsd-check-length) +(put 'minLength 'rng-xsd-check 'rng-xsd-check-min-length) +(put 'maxLength 'rng-xsd-check 'rng-xsd-check-max-length) +(put 'fractionDigits 'rng-xsd-check 'rng-xsd-check-fraction-digits) +(put 'totalDigits 'rng-xsd-check 'rng-xsd-check-total-digits) + +(defun rng-xsd-check-min-exclusive (str less-than-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (funcall less-than-fun limit obj) + obj))) + +(defun rng-xsd-check-min-inclusive (str less-than-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (or (funcall less-than-fun limit obj) + (equal limit obj)) + obj))) + +(defun rng-xsd-check-max-exclusive (str less-than-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (funcall less-than-fun obj limit) + obj))) + +(defun rng-xsd-check-max-inclusive (str less-than-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (or (funcall less-than-fun obj limit) + (equal obj limit)) + obj))) + +(defun rng-xsd-check-min-length (str length-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (>= (funcall length-fun obj) limit) + obj))) + +(defun rng-xsd-check-max-length (str length-fun limit convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (<= (funcall length-fun obj) limit) + obj))) + +(defun rng-xsd-check-length (str length-fun len convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (= (funcall length-fun obj) len) + obj))) + +(defun rng-xsd-check-fraction-digits (str n convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (<= (length (aref obj 2)) n) + obj))) + +(defun rng-xsd-check-total-digits (str n convert &rest args) + (let ((obj (apply convert (cons str args)))) + (and obj + (<= (+ (length (aref obj 1)) + (length (aref obj 2))) + n) + obj))) + +(defun rng-xsd-check-pattern (str regexp convert &rest args) + (and (string-match regexp str) + (apply convert (cons str args)))) + + +(defun rng-xsd-convert-boolean (string) + (and (string-match "\\`[ \t\n\r]*\\(?:\\(true\\|1\\)\\|false\\|0\\)[ \t\n\r]*\\'" string) + (if (match-beginning 1) 'true 'false))) + +(defun rng-xsd-convert-decimal (string) + "Convert a string representing a decimal to an object representing +its values. A decimal value is represented by a vector [SIGN +INTEGER-DIGITS FRACTION-DIGITS] where SIGN is 1 or -1, INTEGER-DIGITS +is a string containing zero or more digits, with no leading zero, and +FRACTION-DIGITS is a string containing zero or more digits with no +trailing digits. For example, -0021.0430 would be represented by [-1 +\"21\" \"043\"]." + (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(0*\\([1-9][0-9]*\\)?\\(\\.\\([0-9]*[1-9]\\)?0*\\)?\\)[ \t\n\r]*\\'" string) + (let ((digits (match-string 2 string))) + (and (not (string= digits ".")) + (not (string= digits "")))) + (let ((integer-digits (match-string 3 string))) + (vector (if (and (equal (match-string 1 string) "-") + ;; Normalize -0 to 0 + integer-digits) + -1 + 1) + (or integer-digits "") + (or (match-string 5 string) ""))))) + +(defun rng-xsd-convert-integer (string) + (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(?:0*\\([1-9][0-9]*\\)\\|0+\\)[ \t\n\r]*\\'" string) + (let ((integer-digits (match-string 2 string))) + (vector (if (and (equal (match-string 1 string) "-") + ;; Normalize -0 to 0 + integer-digits) + -1 + 1) + (or integer-digits "") + "")))) + +(defun rng-xsd-decimal< (n1 n2) + (< (rng-xsd-compare-decimal n1 n2) 0)) + +(defun rng-xsd-compare-decimal (n1 n2) + "Return a < 0, 0, > 0 according as n1 < n2, n1 = n2 or n1 > n2." + (let* ((sign1 (aref n1 0)) + (sign2 (aref n2 0)) + (sign (- sign1 sign2))) + (if (= sign 0) + (* sign1 + (let* ((int1 (aref n1 1)) + (int2 (aref n2 1)) + (len1 (length int1)) + (len2 (length int2)) + (lencmp (- len1 len2))) + (if (eq lencmp 0) + (if (string= int1 int2) + (rng-xsd-strcmp (aref n1 2) (aref n2 2)) + (rng-xsd-strcmp int1 int2)) + lencmp))) + sign))) + +(defconst rng-xsd-float-regexp + (concat "\\`[ \r\n\t]*\\(?:" + "\\(" + "[-+]?\\(?:[0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)" + "\\(?:[eE][-+]?[0-9]+\\)?" + "\\)" + "\\|\\(INF\\)" + "\\|\\(-INF\\)" + "\\|\\(NaN\\)" + "\\)[ \r\n\t]*\\'")) + +(defun rng-xsd-convert-float (string) + (cond ((not (string-match rng-xsd-float-regexp string)) nil) + ((match-beginning 1) + (float (string-to-number (match-string 1 string)))) + ((match-beginning 2) 1.0e+INF) + ((match-beginning 3) -1.0e+INF) + ;; Don't use a NaN float because we want NaN to be equal to NaN + ((match-beginning 4) 'NaN))) + +(defun rng-xsd-float< (f1 f2) + (and (not (eq f1 'NaN)) + (not (eq f2 'NaN)) + (< f1 f2))) + +(defun rng-xsd-convert-token (string regexp) + (and (string-match regexp string) + (match-string 1 string))) + +(defun rng-xsd-convert-hex-binary (string) + (and (string-match "\\`[ \r\n\t]*\\(\\(?:[0-9A-Fa-f][0-9A-Fa-f]\\)*\\)[ \r\n\t]*\\'" + string) + (downcase (match-string 1 string)))) + +(defun rng-xsd-hex-binary-length (obj) + (/ (length obj) 2)) + +(defconst rng-xsd-base64-binary-regexp + (let ((S "[ \t\r\n]*") + (B04 "[AQgw]") + (B16 "[AEIMQUYcgkosw048]") + (B64 "[A-Za-z0-9+/]")) + (concat "\\`" S "\\(?:\\(?:" B64 S "\\)\\{4\\}\\)*" + "\\(?:" B64 S B64 S B16 S "=" S + "\\|" B64 S B04 S "=" S "=" S "\\)?\\'"))) + +(defun rng-xsd-convert-base64-binary (string) + (and (string-match rng-xsd-base64-binary-regexp string) + (replace-regexp-in-string "[ \t\r\n]+" "" string t t))) + +(defun rng-xsd-base64-binary-length (obj) + (let ((n (* (/ (length obj) 4) 3))) + (if (and (> n 0) + (string= (substring obj -1) "=")) + (- n (if (string= (substring obj -2) "==") + 2 + 1)) + n))) + +(defun rng-xsd-convert-any-uri (string) + (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)?*\\'" string) + (string-match "\\`[^#]*\\(?:#[^#]*\\)?\\'" string) + (string-match "\\`\\(?:[a-zA-Z][-+.A-Za-z0-9]*:.+\\|[^:]*\\(?:[#/?].*\\)?\\)\\'" string) + string)) + +(defun rng-xsd-make-date-time-regexp (template) + "Returns a regular expression matching a ISO 8601 date/time. The +template is a string with Y standing for years field, M standing for +months, D standing for day of month, T standing for a literal T, t +standing for time and - standing for a literal hyphen. A time zone is +always allowed at the end. Regardless of the fields appearing in the +template, the regular expression will have twelve groups matching the +year sign, year, month, day of month, hours, minutes, integer seconds, +fractional seconds (including leading period), time zone, time zone +sign, time zone hours, time zone minutes." + (let ((i 0) + (len (length template)) + (parts nil) + first last c) + (while (< i len) + (setq c (aref template i)) + (setq parts + (cons (cond ((eq c ?Y) + (setq first 0) + (setq last 1) + "\\(-\\)?\\(\\(?:[1-9][0-9]*\\)?[0-9]\\{4\\}\\)") + ((eq c ?M) + (or first + (setq first 2)) + (setq last 2) + "\\([0-9][0-9]\\)") + ((eq c ?D) + (or first + (setq first 3)) + (setq last 3) + "\\([0-9][0-9]\\)") + ((eq c ?t) + (or first + (setq first 4)) + (setq last 7) + "\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\(\\.[0-9]*\\)?") + (t (string c))) + parts)) + (setq i (1+ i))) + (while (< last 7) + (setq last (1+ last)) + ;; Add dummy fields that can never much but keep the group + ;; numbers uniform. + (setq parts (cons "\\(\\'X\\)?" parts))) + (setq parts (cons "\\(Z\\|\\([-+]\\)\\([0-9][0-9]\\):\\([0-5][0-9]\\)\\)?[ \t\n\r]*\\'" + parts)) + (setq parts (cons "\\`[ \t\n\r]*" (nreverse parts))) + (while (> first 0) + (setq first (1- first)) + (setq parts (cons "\\(X\\)?" parts))) + (apply 'concat parts))) + +(defconst rng-xsd-seconds-per-day (* 24 60 60)) +(defconst rng-xsd-days-in-month [31 28 31 30 31 30 31 31 30 31 30 31]) + +(defun rng-xsd-days-in-month (year month) + (if (and (= month 2) (rng-xsd-leap-year-p year)) + 29 + (aref rng-xsd-days-in-month (1- month)))) + +(defconst rng-xsd-months-to-days + (let ((v (make-vector 12 nil)) + (total 0) + (i 0)) + (while (< i 12) + (setq total (+ total (aref rng-xsd-days-in-month i))) + (aset v i total) + (setq i (1+ i))) + v)) + +(defun rng-xsd-convert-date-time (string regexp) + "Converts an XML Schema date/time to a list. Returns nil if +invalid. REGEXP is a regexp for parsing the date time as returned by +`rng-xsd-make-date-time-regexp'. The list has 4 members (HAS-TIME-ZONE +DAY SECOND SECOND-FRACTION), where HAS-TIME-ZONE is t or nil depending +on whether a time zone was specified, DAY is an integer giving a day +number (with Jan 1 1AD being day 1), SECOND is the second within that +day, and SECOND-FRACTION is a float giving the fractional part of the +second." + (and (string-match regexp string) + (let ((year-sign (match-string 1 string)) + (year (match-string 2 string)) + (month (match-string 3 string)) + (day (match-string 4 string)) + (hour (match-string 5 string)) + (minute (match-string 6 string)) + (second (match-string 7 string)) + (second-fraction (match-string 8 string)) + (has-time-zone (match-string 9 string)) + (time-zone-sign (match-string 10 string)) + (time-zone-hour (match-string 11 string)) + (time-zone-minute (match-string 12 string))) + (setq year-sign (if year-sign -1 1)) + (setq year + (if year + (* year-sign + (string-to-number year)) + 2000)) + (setq month + (if month (string-to-number month) 1)) + (setq day + (if day (string-to-number day) 1)) + (setq hour + (if hour (string-to-number hour) 0)) + (setq minute + (if minute (string-to-number minute) 0)) + (setq second + (if second (string-to-number second) 0)) + (setq second-fraction + (if second-fraction + (float (string-to-number second-fraction)) + 0.0)) + (setq has-time-zone (and has-time-zone t)) + (setq time-zone-sign + (if (equal time-zone-sign "-") -1 1)) + (setq time-zone-hour + (if time-zone-hour (string-to-number time-zone-hour) 0)) + (setq time-zone-minute + (if time-zone-minute (string-to-number time-zone-minute) 0)) + (and (>= month 1) + (<= month 12) + (>= day 1) + (<= day (rng-xsd-days-in-month year month)) + (<= hour 23) + (<= minute 59) + (<= second 60) ; leap second + (<= time-zone-hour 23) + (<= time-zone-minute 59) + (cons has-time-zone + (rng-xsd-add-seconds + (list (rng-xsd-date-to-days year month day) + (rng-xsd-time-to-seconds hour minute second) + second-fraction) + (* (rng-xsd-time-to-seconds time-zone-hour + time-zone-minute + 0) + (- time-zone-sign)))))))) + +(defun rng-xsd-leap-year-p (year) + (and (= (% year 4) 0) + (or (/= (% year 100) 0) + (= (% year 400) 0)))) + +(defun rng-xsd-time-to-seconds (hour minute second) + (+ (* (+ (* hour 60) + minute) + 60) + second)) + +(defconst rng-xsd-max-tz (rng-xsd-time-to-seconds 14 0 0)) + +(defun rng-xsd-date-time< (dt1 dt2) + (cond ((eq (car dt1) (car dt2)) + (rng-xsd-number-list< (cdr dt1) (cdr dt2))) + ((car dt1) + (rng-xsd-number-list< (cdr dt1) + (rng-xsd-add-seconds (cdr dt2) + (- rng-xsd-max-tz)))) + (t + (rng-xsd-number-list< (rng-xsd-add-seconds (cdr dt1) + rng-xsd-max-tz) + (cdr dt2))))) + +(defun rng-xsd-add-seconds (date offset) + (let ((day (nth 0 date)) + (second (+ (nth 1 date) offset)) + (fraction (nth 2 date))) + (cond ((< second 0) + (list (1- day) + (+ second rng-xsd-seconds-per-day) + fraction)) + ((>= second rng-xsd-seconds-per-day) + (list (1+ day) + (- second rng-xsd-seconds-per-day) + fraction)) + (t (list day second fraction))))) + +(defun rng-xsd-number-list< (numbers1 numbers2) + (while (and numbers1 (= (car numbers1) (car numbers2))) + (setq numbers1 (cdr numbers1)) + (setq numbers2 (cdr numbers2))) + (and numbers1 + (< (car numbers1) (car numbers2)))) + +(defun rng-xsd-date-to-days (year month day) + "Return a unique day number where Jan 1 1 AD is day 1" + (if (> year 0) ; AD + (+ (rng-xsd-days-in-years (- year 1)) + (rng-xsd-day-number-in-year year month day)) + (- (+ (- (rng-xsd-days-in-years (- 3 year)) + (rng-xsd-days-in-years 3)) + (- (if (rng-xsd-leap-year-p year) 366 365) + (rng-xsd-day-number-in-year year month day)))))) + +(defun rng-xsd-days-in-years (years) + "The number of days in YEARS years where the first year is 1AD." + (+ (* 365 years) + (/ years 4) + (- (/ years 100)) + (/ years 400))) + +(defun rng-xsd-day-number-in-year (year month day) + (+ (if (= month 1) + 0 + (aref rng-xsd-months-to-days (- month 2))) + day + (if (and (> month 2) + (rng-xsd-leap-year-p year)) + 1 + 0))) + +(defconst rng-xsd-duration-regexp + "\\`[ \t\r\n]*\\(-\\)?P\ +\\([0-9]+Y\\)?\\([0-9]+M\\)?\\([0-9]+D\\)?\ +\\(?:T\\([0-9]+H\\)?\\([0-9]+M\\)?\ +\\(\\([0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)S\\)?\\)?\ +[ \t\r\n]*\\'") + + +(defun rng-xsd-convert-duration (string) + (and (string-match rng-xsd-duration-regexp string) + (let ((last (substring string -1))) + (not (or (string= last "P") + (string= last "T")))) + ;; years months days hours minutes seconds + (let ((v (make-vector 6 0)) + (sign (if (match-beginning 1) -1 1)) + (i 0)) + (while (< i 6) + (let ((start (match-beginning (+ i 2)))) + (when start + (aset v i (* sign + (string-to-number + (substring string + start + (1- (match-end (+ i 2))))))))) + (setq i (1+ i))) + ;; Force seconds to be float so that equal works properly. + (aset v 5 (float (aref v 5))) + v))) + +(defconst rng-xsd-min-seconds-per-month (* 28 rng-xsd-seconds-per-day)) + +(defun rng-xsd-duration< (d1 d2) + (let* ((months1 (rng-xsd-duration-months d1)) + (months2 (rng-xsd-duration-months d2)) + (seconds1 (rng-xsd-duration-seconds d1)) + (seconds2 (rng-xsd-duration-seconds d2))) + (cond ((< months1 months2) + (if (< (- seconds1 seconds2) rng-xsd-min-seconds-per-month) + t + (rng-xsd-months-seconds< months1 seconds1 months2 seconds2))) + ((> months1 months2) + (if (< (- seconds2 seconds1) rng-xsd-min-seconds-per-month) + nil + (rng-xsd-months-seconds< months1 seconds1 months2 seconds2))) + (t (< seconds1 seconds2))))) + +(defconst xsd-duration-reference-dates + '((1696 . 9) (1697 . 2) (1903 . 3) (1903 . 7))) + +(defun rng-xsd-months-seconds< (months1 seconds1 months2 seconds2) + (let ((ret t) + (ref-dates xsd-duration-reference-dates)) + (while (let* ((ref-date (car ref-dates)) + (ref-year (car ref-date)) + (ref-month (cdr ref-date))) + (unless (< (+ (rng-xsd-month-seconds months1 + ref-year + ref-month) + seconds1) + (+ (rng-xsd-month-seconds months2 + ref-year + ref-month) + seconds2)) + (setq ret nil)) + (and ret + (setq ref-dates (cdr ref-dates))))) + ret)) + + +(defun rng-xsd-month-seconds (months ref-year ref-month) + "Return the seconds in a number of months starting on a reference date. +Returns a floating point number." + (* (rng-xsd-month-days (abs months) ref-year ref-month) + (float rng-xsd-seconds-per-day) + (if (< months 0) -1.0 1.0))) + +(defconst rng-xsd-years-per-gregorian-cycle 400) +(defconst rng-xsd-months-per-gregorian-cycle + (* rng-xsd-years-per-gregorian-cycle 12)) +(defconst rng-xsd-leap-years-per-gregorian-cycle (- 100 (- 4 1))) +(defconst rng-xsd-days-per-gregorian-cycle + (+ (* 365 rng-xsd-years-per-gregorian-cycle) + rng-xsd-leap-years-per-gregorian-cycle)) + +(defun rng-xsd-month-days (months ref-year ref-month) + "Return the days in a number of months starting on a reference date. +MONTHS must be an integer >= 0." + (let ((days 0)) + (setq months (mod months rng-xsd-months-per-gregorian-cycle)) + ;; This may be rather slow, but it is highly unlikely + ;; ever to be used in real life. + (while (> months 0) + (setq days + (+ (rng-xsd-days-in-month ref-year ref-month) + days)) + (setq ref-month + (if (eq ref-month 12) + (progn + (setq ref-year (1+ ref-year)) + 1) + (1+ ref-month))) + (setq months (1- months))) + (+ (* (/ months rng-xsd-months-per-gregorian-cycle) + rng-xsd-days-per-gregorian-cycle) + days))) + +(defun rng-xsd-duration-months (d) + (+ (* (aref d 0) 12) + (aref d 1))) + +(defun rng-xsd-duration-seconds (d) + (+ (* (+ (* (+ (* (aref d 2) + 24.0) + (aref d 3)) + 60.0) + (aref d 4)) + 60.0) + (aref d 5))) + +(defun rng-xsd-convert-qname (string) + (and (string-match "\\`[ \r\n\t]*\\([_[:alpha:]][-._[:alnum:]]*\\(:[_[:alpha:]][-._[:alnum:]]*\\)?\\)[ \r\n\t]*\\'" string) + (let ((colon (match-beginning 2)) + (context (apply (car rng-dt-namespace-context-getter) + (cdr rng-dt-namespace-context-getter)))) + (if colon + (let* ((prefix (substring string + (match-beginning 1) + colon)) + (binding (assoc prefix (cdr context)))) + (and binding + (cons (cdr binding) + (substring string + (1+ colon) + (match-end 1))))) + (cons (car context) + (match-string 1 string)))))) + +(defun rng-xsd-convert-list (string convert &rest args) + (let* ((tokens (split-string string "[ \t\n\r]+")) + (tem tokens)) + (while tem + (let ((obj (apply convert + (cons (car tem) args)))) + (cond (obj + (setcar tem obj) + (setq tem (cdr tem))) + (t + (setq tokens nil) + (setq tem nil))))) + ;; Fortuitously this returns nil if the list is empty + ;; which is what we want since the list types + ;; have to have one or more members. + tokens)) + +(defun rng-xsd-strcmp (s1 s2) + (cond ((string= s1 s2) 0) + ((string< s1 s2) -1) + (t 1))) + +(put 'string 'rng-xsd-convert '(identity)) +(put 'string 'rng-xsd-length 'length) +(put 'string 'rng-xsd-matches-anything t) + +(put 'normalizedString 'rng-xsd-convert '(identity)) +(put 'normalizedString 'rng-xsd-length 'length) +(put 'normalizedString 'rng-xsd-matches-anything t) + +(put 'token 'rng-xsd-convert '(identity)) +(put 'token 'rng-xsd-length 'length) +(put 'token 'rng-xsd-matches-anything t) + +(put 'hexBinary 'rng-xsd-convert '(rng-xsd-convert-hex-binary)) +(put 'hexBinary 'rng-xsd-length 'rng-xsd-hex-binary-length) + +(put 'base64Binary 'rng-xsd-convert '(rng-xsd-convert-base64-binary)) +(put 'base64Binary 'rng-xsd-length 'rng-xsd-base64-binary-length) + +(put 'boolean 'rng-xsd-convert '(rng-xsd-convert-boolean)) + +(put 'float 'rng-xsd-convert '(rng-xsd-convert-float)) +(put 'float 'rng-xsd-less-than 'rng-xsd-float<) + +(put 'double 'rng-xsd-convert '(rng-xsd-convert-float)) +(put 'double 'rng-xsd-less-than 'rng-xsd-float<) + +(put 'decimal 'rng-xsd-convert '(rng-xsd-convert-decimal)) +(put 'decimal 'rng-xsd-less-than 'rng-xsd-decimal<) + +(put 'integer 'rng-xsd-convert '(rng-xsd-convert-integer)) +(put 'integer 'rng-xsd-less-than 'rng-xsd-decimal<) + +(defun rng-xsd-def-integer-type (name min max) + (put name 'rng-xsd-less-than 'rng-xsd-decimal<) + (put name + 'rng-xsd-convert + (cdr (rng-xsd-compile 'integer + (append (and min `((minInclusive . ,min))) + (and max `((maxInclusive . ,max)))))))) + +(defun rng-xsd-def-token-type (name regexp) + (put name 'rng-xsd-convert (list 'rng-xsd-convert-token + (concat "\\`[\r\n\t ]*\\(" + regexp + "\\)[\r\n\t ]*\\'"))) + (put name 'rng-xsd-length 'length)) + +(rng-xsd-def-token-type 'NMTOKEN "[-.:_[:alnum:]]+") +(rng-xsd-def-token-type 'Name "[:_[:alpha:]][-.:_[:alnum:]]*") +(rng-xsd-def-token-type 'NCName "[_[:alpha:]][-._[:alnum:]]*") +(rng-xsd-def-token-type 'language + "[a-zA-Z]\\{1,8\\}\\(?:-[a-zA-Z0-9]\\{1,8\\}\\)*") + +(put 'ENTITY 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) +(put 'ENTITY 'rng-xsd-length 'length) +(put 'ID 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) +(put 'ID 'rng-xsd-length 'length) +(put 'IDREF 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) +(put 'IDREF 'rng-xsd-length 'length) + +(defun rng-xsd-def-list-type (name member-name) + (put name 'rng-xsd-convert (cons 'rng-xsd-convert-list + (get member-name 'rng-xsd-convert))) + (put name 'rng-xsd-length 'length)) + +(rng-xsd-def-list-type 'NMTOKENS 'NMTOKEN) +(rng-xsd-def-list-type 'IDREFS 'IDREF) +(rng-xsd-def-list-type 'ENTITIES 'ENTITY) + +(put 'anyURI 'rng-xsd-convert '(rng-xsd-convert-any-uri)) +(put 'anyURI 'rng-xsd-length 'length) + +(put 'QName 'rng-xsd-convert '(rng-xsd-convert-qname)) +(put 'NOTATION 'rng-xsd-convert '(rng-xsd-convert-qname)) + +(defconst rng-xsd-long-max "9223372036854775807") +(defconst rng-xsd-long-min "-9223372036854775808") +(defconst rng-xsd-int-max "2147483647") +(defconst rng-xsd-int-min "-2147483648") +(defconst rng-xsd-short-max "32767") +(defconst rng-xsd-short-min "-32768") +(defconst rng-xsd-byte-max "127") +(defconst rng-xsd-byte-min "-128") +(defconst rng-xsd-unsigned-long-max "18446744073709551615") +(defconst rng-xsd-unsigned-int-max "4294967295") +(defconst rng-xsd-unsigned-short-max "65535") +(defconst rng-xsd-unsigned-byte-max "255") + +(rng-xsd-def-integer-type 'nonNegativeInteger "0" nil) +(rng-xsd-def-integer-type 'positiveInteger "1" nil) +(rng-xsd-def-integer-type 'nonPositiveInteger nil "0") +(rng-xsd-def-integer-type 'negativeInteger nil "-1") +(rng-xsd-def-integer-type 'long rng-xsd-long-min rng-xsd-long-max) +(rng-xsd-def-integer-type 'int rng-xsd-int-min rng-xsd-int-max) +(rng-xsd-def-integer-type 'short rng-xsd-short-min rng-xsd-short-max) +(rng-xsd-def-integer-type 'byte rng-xsd-byte-min rng-xsd-byte-max) +(rng-xsd-def-integer-type 'unsignedLong "0" rng-xsd-unsigned-long-max) +(rng-xsd-def-integer-type 'unsignedInt "0" rng-xsd-unsigned-int-max) +(rng-xsd-def-integer-type 'unsignedShort "0" rng-xsd-unsigned-short-max) +(rng-xsd-def-integer-type 'unsignedByte "0" rng-xsd-unsigned-byte-max) + +(defun rng-xsd-def-date-time-type (name template) + (put name 'rng-xsd-convert (list 'rng-xsd-convert-date-time + (rng-xsd-make-date-time-regexp template))) + (put name 'rng-xsd-less-than 'rng-xsd-date-time<)) + +(rng-xsd-def-date-time-type 'dateTime "Y-M-DTt") +(rng-xsd-def-date-time-type 'time "t") +(rng-xsd-def-date-time-type 'date "Y-M-D") +(rng-xsd-def-date-time-type 'gYearMonth "Y-M") +(rng-xsd-def-date-time-type 'gYear "Y") +(rng-xsd-def-date-time-type 'gMonthDay "--M-D") +(rng-xsd-def-date-time-type 'gDay "---D") +(rng-xsd-def-date-time-type 'gMonth "--M") + +(put 'duration 'rng-xsd-convert '(rng-xsd-convert-duration)) +(put 'duration 'rng-xsd-less-than 'rng-xsd-duration<) + +(provide 'rng-xsd) + +;; arch-tag: 6b05510e-a5bb-4b99-8618-4660d00d0abb +;;; rng-xsd.el ends here diff --git a/lisp/nxml/test.invalid.xml b/lisp/nxml/test.invalid.xml new file mode 100644 index 00000000000..87a0031f8e7 --- /dev/null +++ b/lisp/nxml/test.invalid.xml @@ -0,0 +1,11 @@ +<html xmlns="http://www.w3.org/1999/xhtml"> + <head> + <title>An invalid document</title> + </head> + <body> + <p>This XHTML document is <span class="#foo">invalid</span>.</p> + </body> +</html> + +<!-- arch-tag: 8127c8be-d617-46f5-bdf2-c9159a417c38 + (do not change this comment) --> diff --git a/lisp/nxml/test.valid.xml b/lisp/nxml/test.valid.xml new file mode 100644 index 00000000000..c11380a0e41 --- /dev/null +++ b/lisp/nxml/test.valid.xml @@ -0,0 +1,11 @@ +<html xmlns="http://www.w3.org/1999/xhtml"> + <head> + <title>A valid document</title> + </head> + <body> + <p>This is a valid, albeit boring, XHTML document.</p> + </body> +</html> + +<!-- arch-tag: 6f7701be-ec51-48d0-bb63-38ed564718d6 + (do not change this comment) --> diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el new file mode 100644 index 00000000000..add55bf9840 --- /dev/null +++ b/lisp/nxml/xmltok.el @@ -0,0 +1,1928 @@ +;;; xmltok.el --- XML tokenization + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This implements an XML 1.0 parser. It also implements the XML +;; Namespaces Recommendation. It is designed to be conforming, but it +;; works a bit differently from a normal XML parser. An XML document +;; consists of the prolog and an instance. The prolog is parsed as a +;; single unit using `xmltok-forward-prolog'. The instance is +;; considered as a sequence of tokens, where a token is something like +;; a start-tag, a comment, a chunk of data or a CDATA section. The +;; tokenization of the instance is stateless: the tokenization of one +;; part of the instance does not depend on tokenization of the +;; preceding part of the instance. This allows the instance to be +;; parsed incrementally. The main entry point is `xmltok-forward': +;; this can be called at any point in the instance provided it is +;; between tokens. The other entry point is `xmltok-forward-special' +;; which skips over tokens other comments, processing instructions or +;; CDATA sections (i.e. the constructs in an instance that can contain +;; less than signs that don't start a token). +;; +;; This is a non-validating XML 1.0 processor. It does not resolve +;; parameter entities (including the external DTD subset) and it does +;; not resolve external general entities. +;; +;; It is non-conformant by design in the following respects. +;; +;; 1. It expects the client to detect aspects of well-formedness that +;; are not internal to a single token, specifically checking that +;; end-tags match start-tags and that the instance contains exactly +;; one element. +;; +;; 2. It expects the client to detect duplicate attributes. Detection +;; of duplicate attributes after expansion of namespace prefixes +;; requires the namespace processing state. Detection of duplicate +;; attributes before expansion of namespace prefixes does not, but is +;; redundant given that the client will do detection of duplicate +;; attributes after expansion of namespace prefixes. +;; +;; 3. It allows the client to recover from well-formedness errors. +;; This is essential for use in applications where the document is +;; being parsed during the editing process. +;; +;; 4. It does not support documents that do not conform to the lexical +;; requirements of the XML Namespaces Recommendation (e.g. a document +;; with a colon in an entity name). +;; +;; There are also a number of things that have not yet been +;; implemented that make it non-conformant. +;; +;; 1. It does not implement default attributes. ATTLIST declarations +;; are parsed, but no checking is done on the content of attribute +;; value literals specifying default attribute values, and default +;; attribute values are not reported to the client. +;; +;; 2. It does not implement internal entities containing elements. If +;; an internal entity is referenced and parsing its replacement text +;; yields one or more tags, then it will skip the reference and +;; report this to the client. +;; +;; 3. It does not check the syntax of public identifiers in the DTD. +;; +;; 4. It allows some non-ASCII characters in certain situations where +;; it should not. For example, it only enforces XML 1.0's +;; restrictions on name characters strictly for ASCII characters. The +;; problem here is XML's character model is based squarely on Unicode, +;; whereas Emacs's is not (as of version 21). It is not clear what +;; the right thing to do is. + +;;; Code: + +(defvar xmltok-type nil) +(defvar xmltok-start nil) +(defvar xmltok-name-colon nil) +(defvar xmltok-name-end nil) +(defvar xmltok-replacement nil + "String containing replacement for a character or entity reference.") + +(defvar xmltok-attributes nil + "List containing attributes of last scanned element. +Each member of the list is a vector representing an attribute, which +can be accessed using the functions `xmltok-attribute-name-start', +`xmltok-attribute-name-colon', `xmltok-attribute-name-end', +`xmltok-attribute-value-start', `xmltok-attribute-value-end', +`xmltok-attribute-raw-normalized-value', `xmltok-attribute-refs'.") + +(defvar xmltok-namespace-attributes nil + "List containing namespace declarations of last scanned element. +List has same format as `xmltok-attributes'.") + +(defvar xmltok-dtd nil + "Information about the DTD used by `xmltok-forward'. +`xmltok-forward-prolog' sets this up. + +It consists of an alist of general entity names vs definitions. The +first member of the alist is t if references to entities not in the +alist are well-formed \(e.g. because there's an external subset that +wasn't parsed). + +Each general entity name is a string. The definition is either nil, a +symbol, a string, a cons cell. If the definition is nil, then it +means that it's an internal entity but the result of parsing it is +unknown. If it is a symbol, then the symbol is either `unparsed', +meaning the entity is an unparsed entity, `external', meaning the +entity is or references an external entity, `element', meaning the +entity includes one or more elements, or `not-well-formed', meaning +the replacement text is not well-formed. If the definition is a +string, then the replacement text of the entity is that string; this +happens only during the parsing of the prolog. If the definition is a +cons cell \(ER . AR), then ER specifies the string that results from +referencing the entity in element content and AR is either nil, +meaning the replacement text included a <, or a string which is the +normalized attribute value.") + +(defvar xmltok-dependent-regions nil + "List of descriptors of regions that a parsed token depends on. + +A token depends on a region if the region occurs after the token and a +change in the region may require the token to be reparsed. This only +happens with markup that is not well-formed. For example, if a <? +occurs without a matching ?>, then the <? is returned as a +not-well-formed token. However, this token is dependent on region +from the end of the token to the end of the buffer: if this ever +contains ?> then the buffer must be reparsed from the <?. + +A region descriptor is a list (FUN START END ARG ...), where FUN is a +function to be called when the region changes, START and END are +integers giving the start and end of the region, and ARG... are +additional arguments to be passed to FUN. FUN will be called with 5 +arguments followed by the additional arguments if any: the position of +the start of the changed area in the region, the position of the end +of the changed area in the region, the length of the changed area +before the change, the position of the start of the region, the +position of the end of the region. FUN must return non-nil if the +region needs reparsing. FUN will be called in a save-excursion with +match-data saved. + +`xmltok-forward', `xmltok-forward-special' and `xmltok-forward-prolog' +may add entries to the beginning of this list, but will not clear it. +`xmltok-forward' and `xmltok-forward-special' will only add entries +when returning tokens of type not-well-formed.") + +(defvar xmltok-errors nil + "List of errors detected by `xmltok-forward' and `xmltok-forward-prolog'. +When `xmltok-forward' and `xmltok-forward-prolog' detect a +well-formedness error, they will add an entry to the beginning of this +list. Each entry is a vector [MESSAGE START END], where MESSAGE is a +string giving the error message and START and END are integers +indicating the position of the error.") + +(defmacro xmltok-save (&rest body) + `(let (xmltok-type + xmltok-start + xmltok-name-colon + xmltok-name-end + xmltok-replacement + xmltok-attributes + xmltok-namespace-attributes + xmltok-dependent-regions + xmltok-errors) + ,@body)) + +(put 'xmltok-save 'lisp-indent-function 0) +(def-edebug-spec xmltok-save t) + +(defsubst xmltok-attribute-name-start (att) + (aref att 0)) + +(defsubst xmltok-attribute-name-colon (att) + (aref att 1)) + +(defsubst xmltok-attribute-name-end (att) + (aref att 2)) + +(defsubst xmltok-attribute-value-start (att) + (aref att 3)) + +(defsubst xmltok-attribute-value-end (att) + (aref att 4)) + +(defsubst xmltok-attribute-raw-normalized-value (att) + "Return an object representing the normalized value of ATT. +This can t indicating that the normalized value is the same as the +buffer substring from the start to the end of the value or nil +indicating that the value is not well-formed or a string." + (aref att 5)) + +(defsubst xmltok-attribute-refs (att) + "Return a list of the entity and character references in ATT. +Each member is a vector [TYPE START END] where TYPE is either char-ref +or entity-ref and START and END are integers giving the start and end +of the reference. Nested entity references are not included in the list." + (aref att 6)) + +(defun xmltok-attribute-prefix (att) + (let ((colon (xmltok-attribute-name-colon att))) + (and colon + (buffer-substring-no-properties (xmltok-attribute-name-start att) + colon)))) + +(defun xmltok-attribute-local-name (att) + (let ((colon (xmltok-attribute-name-colon att))) + (buffer-substring-no-properties (if colon + (1+ colon) + (xmltok-attribute-name-start att)) + (xmltok-attribute-name-end att)))) + +(defun xmltok-attribute-value (att) + (let ((rnv (xmltok-attribute-raw-normalized-value att))) + (and rnv + (if (stringp rnv) + rnv + (buffer-substring-no-properties (xmltok-attribute-value-start att) + (xmltok-attribute-value-end att)))))) + +(defun xmltok-start-tag-prefix () + (and xmltok-name-colon + (buffer-substring-no-properties (1+ xmltok-start) + xmltok-name-colon))) + +(defun xmltok-start-tag-local-name () + (buffer-substring-no-properties (1+ (or xmltok-name-colon + xmltok-start)) + xmltok-name-end)) + +(defun xmltok-end-tag-prefix () + (and xmltok-name-colon + (buffer-substring-no-properties (+ 2 xmltok-start) + xmltok-name-colon))) + +(defun xmltok-end-tag-local-name () + (buffer-substring-no-properties (if xmltok-name-colon + (1+ xmltok-name-colon) + (+ 2 xmltok-start)) + xmltok-name-end)) + +(defun xmltok-start-tag-qname () + (buffer-substring-no-properties (+ xmltok-start 1) xmltok-name-end)) + +(defun xmltok-end-tag-qname () + (buffer-substring-no-properties (+ xmltok-start 2) xmltok-name-end)) + +(defsubst xmltok-make-attribute (name-begin + name-colon + name-end + &optional + value-begin + value-end + raw-normalized-value) + "Make an attribute. RAW-NORMALIZED-VALUE is nil if the value is +not well-formed, t if the normalized value is the string between +VALUE-BEGIN and VALUE-END, otherwise a STRING giving the value." + (vector name-begin + name-colon + name-end + value-begin + value-end + raw-normalized-value + nil)) + +(defsubst xmltok-error-message (err) + (aref err 0)) + +(defsubst xmltok-error-start (err) + (aref err 1)) + +(defsubst xmltok-error-end (err) + (aref err 2)) + +(defsubst xmltok-make-error (message start end) + (vector message start end)) + +(defun xmltok-add-error (message &optional start end) + (setq xmltok-errors + (cons (xmltok-make-error message + (or start xmltok-start) + (or end (point))) + xmltok-errors))) + +(defun xmltok-add-dependent (fun &optional start end &rest args) + (setq xmltok-dependent-regions + (cons (cons fun + (cons (or start xmltok-start) + (cons (or end (point-max)) + args))) + xmltok-dependent-regions))) + +(defun xmltok-forward () + (setq xmltok-start (point)) + (let* ((case-fold-search nil) + (space-count (skip-chars-forward " \t\r\n")) + (ch (char-after))) + (cond ((eq ch ?\<) + (cond ((> space-count 0) + (setq xmltok-type 'space)) + (t + (goto-char (1+ (point))) + (xmltok-scan-after-lt)))) + ((eq ch ?\&) + (cond ((> space-count 0) + (setq xmltok-type 'space)) + (t + (goto-char (1+ (point))) + (xmltok-scan-after-amp + (lambda (start end) + (xmltok-handle-entity start end)))))) + ((re-search-forward "[<&]\\|\\(]]>\\)" nil t) + (cond ((not (match-beginning 1)) + (goto-char (match-beginning 0)) + ;; must have got a non-space char + (setq xmltok-type 'data)) + ((= (match-beginning 1) xmltok-start) + (xmltok-add-error "Found `]]>' not closing a CDATA section") + (setq xmltok-type 'not-well-formed)) + (t + (goto-char (match-beginning 0)) + (setq xmltok-type + (if (= (point) (+ xmltok-start space-count)) + 'space + 'data))))) + ((eq ch nil) + (setq xmltok-type + (if (> space-count 0) + 'space + nil))) + (t + (goto-char (point-max)) + (setq xmltok-type 'data))))) + +(defun xmltok-forward-special (bound) + "Scan forward past the first special token starting at or after point. +Return nil if there is no special token that starts before BOUND. +CDATA sections, processing instructions and comments (and indeed +anything starting with < following by ? or !) count +as special. Return the type of the token." + (when (re-search-forward "<[?!]" (1+ bound) t) + (setq xmltok-start (match-beginning 0)) + (goto-char (1+ xmltok-start)) + (let ((case-fold-search nil)) + (xmltok-scan-after-lt)))) + +(eval-when-compile + + ;; A symbolic regexp is represented by a list whose CAR is the string + ;; containing the regexp and whose cdr is a list of symbolic names + ;; for the groups in the string. + + ;; Construct a symbolic regexp from a regexp. + (defun xmltok-r (str) + (cons str nil)) + + ;; Concatenate zero of more regexps and symbolic regexps. + (defun xmltok+ (&rest args) + (let (strs names) + (while args + (let ((arg (car args))) + (if (stringp arg) + (setq strs (cons arg strs)) + (setq strs (cons (car arg) strs)) + (setq names (cons (cdr arg) names))) + (setq args (cdr args)))) + (cons (apply 'concat (nreverse strs)) + (apply 'append (nreverse names)))))) + +(eval-when-compile + ;; Make a symbolic group named NAME from the regexp R. + ;; R may be a symbolic regexp or an ordinary regexp. + (defmacro xmltok-g (name &rest r) + (let ((sym (make-symbol "r"))) + `(let ((,sym (xmltok+ ,@r))) + (if (stringp ,sym) + (cons (concat "\\(" ,sym "\\)") (cons ',name nil)) + (cons (concat "\\(" (car ,sym) "\\)") (cons ',name (cdr ,sym))))))) + + (defun xmltok-p (&rest r) (xmltok+ "\\(?:" + (apply 'xmltok+ r) + "\\)")) + + ;; Get the group index of ELEM in a LIST of symbols. + (defun xmltok-get-index (elem list) + (or elem + (error "Missing group name")) + (let ((found nil) + (i 1)) + (while list + (cond ((eq elem (car list)) + (setq found i) + (setq list nil)) + (t + (setq i (1+ i)) + (setq list (cdr list))))) + (or found + (error "Bad group name %s" elem)))) + + ;; Define a macro SYM using a symbolic regexp R. + ;; SYM can be called in three ways: + ;; (SYM regexp) + ;; expands to the regexp in R + ;; (SYM start G) + ;; expands to + ;; (match-beginning N) + ;; where N is the group index of G in R. + ;; (SYM end G) + ;; expands to + ;; (match-end N) + ;; where N is the group index of G in R. + (defmacro xmltok-defregexp (sym r) + `(defalias ',sym + (let ((r ,r)) + `(macro lambda (action &optional group-name) + (cond ((eq action 'regexp) + ,(car r)) + ((or (eq action 'start) (eq action 'beginning)) + (list 'match-beginning (xmltok-get-index group-name + ',(cdr r)))) + ((eq action 'end) + (list 'match-end (xmltok-get-index group-name + ',(cdr r)))) + ((eq action 'string) + (list 'match-string + (xmltok-get-index group-name ',(cdr r)))) + ((eq action 'string-no-properties) + (list 'match-string-no-properties + (xmltok-get-index group-name ',(cdr r)))) + (t (error "Invalid action: %s" action)))))))) + + +(eval-when-compile + (let* ((or "\\|") + (open "\\(?:") + (gopen "\\(") + (close "\\)") + (name-start-char "[_[:alpha:]]") + (name-continue-not-start-char "[-.[:digit:]]") + (name-continue-char "[-._[:alnum:]]") + (* "*") + (+ "+") + (opt "?") + (question "\\?") + (s "[ \r\t\n]") + (s+ (concat s +)) + (s* (concat s *)) + (ncname (concat name-start-char name-continue-char *)) + (entity-ref + (xmltok+ (xmltok-g entity-name ncname) + (xmltok-g entity-ref-close ";") opt)) + (decimal-ref + (xmltok+ (xmltok-g decimal "[0-9]" +) + (xmltok-g decimal-ref-close ";") opt)) + (hex-ref + (xmltok+ "x" open + (xmltok-g hex "[0-9a-fA-F]" +) + (xmltok-g hex-ref-close ";") opt + close opt)) + (char-ref + (xmltok+ (xmltok-g number-sign "#") + open decimal-ref or hex-ref close opt)) + (start-tag-close + (xmltok+ open (xmltok-g start-tag-close s* ">") + or open (xmltok-g empty-tag-slash s* "/") + (xmltok-g empty-tag-close ">") opt close + or (xmltok-g start-tag-s s+) + close)) + (start-tag + (xmltok+ (xmltok-g start-tag-name + ncname (xmltok-g start-tag-colon ":" ncname) opt) + start-tag-close opt)) + (end-tag + (xmltok+ (xmltok-g end-tag-slash "/") + open (xmltok-g end-tag-name + ncname + (xmltok-g end-tag-colon ":" ncname) opt) + (xmltok-g end-tag-close s* ">") opt + close opt)) + (comment + (xmltok+ (xmltok-g markup-declaration "!") + (xmltok-g comment-first-dash "-" + (xmltok-g comment-open "-") opt) opt)) + (cdata-section + (xmltok+ "!" + (xmltok-g marked-section-open "\\[") + open "C" + open "D" + open "A" + open "T" + open "A" + (xmltok-g cdata-section-open "\\[" ) opt + close opt ; A + close opt ; T + close opt ; A + close opt ; D + close opt)) ; C + (processing-instruction + (xmltok-g processing-instruction-question question))) + + (xmltok-defregexp xmltok-ncname (xmltok+ open ncname close)) + + (xmltok-defregexp xmltok-after-amp + (xmltok+ entity-ref or char-ref)) + (xmltok-defregexp xmltok-after-lt + (xmltok+ start-tag + or end-tag + ;; cdata-section must come before comment + ;; because we treat <! as a comment + ;; and Emacs doesn't do fully greedy matching + ;; by default + or cdata-section + or comment + or processing-instruction)) + (xmltok-defregexp + xmltok-attribute + (let* ((lit1 + (xmltok+ "'" + "[^<'&\r\n\t]*" + (xmltok-g complex1 "[&\r\n\t][^<']*") opt + "'")) + (lit2 (cons (replace-regexp-in-string "'" "\"" (car lit1)) + '(complex2))) + (literal (xmltok-g literal lit1 or lit2)) + (name (xmltok+ open (xmltok-g xmlns "xmlns") or ncname close + (xmltok-g colon ":" ncname) opt))) + (xmltok+ (xmltok-g name name) + s* "=" + ;; If the literal isn't followed by what it should be, + ;; then the closing delimiter is probably really the + ;; opening delimiter of another literal, so don't + ;; absorb the literal in this case. + open s* literal start-tag-close close opt))) + (xmltok-defregexp + xmltok-xml-declaration + (let* ((literal-content "[-._:a-zA-Z0-9]+") + (literal + (concat open "\"" literal-content "\"" + or "'" literal-content "'" close)) + (version-att + (xmltok+ open + s+ (xmltok-g version-name "version") + s* "=" + s* (xmltok-g version-value literal) + close opt)) + (encoding-att + (xmltok+ open + s+ (xmltok-g encoding-name "encoding") + s* "=" + s* (xmltok-g encoding-value literal) + close opt)) + (yes-no + (concat open "yes" or "no" close)) + (standalone-att + (xmltok+ open + s+ (xmltok-g standalone-name "standalone") + s* "=" + s* (xmltok-g standalone-value + "\"" yes-no "\"" or "'" yes-no "'") + close opt))) + (xmltok+ "<" question "xml" + version-att + encoding-att + standalone-att + s* question ">"))) + (xmltok-defregexp + xmltok-prolog + (let* ((single-char (xmltok-g single-char "[[|,(\"'>]")) + (internal-subset-close (xmltok-g internal-subset-close + "][ \t\r\n]*>")) + (starts-with-close-paren + (xmltok-g close-paren + ")" + (xmltok-p + (xmltok-g close-paren-occur "[+?]") + or + (xmltok-g close-paren-star "\\*")) + opt)) + (starts-with-percent + (xmltok-g percent + "%" (xmltok-g param-entity-ref + ncname + (xmltok-g param-entity-ref-close + ";") opt) opt)) + (starts-with-nmtoken-not-name + (xmltok-g nmtoken + (xmltok-p name-continue-not-start-char or ":") + (xmltok-p name-continue-char or ":") *)) + (nmtoken-after-colon + (xmltok+ + (xmltok-p name-continue-not-start-char or ":") + (xmltok-p name-continue-char or ":") * + or + name-start-char + name-continue-char * + ":" + (xmltok-p name-continue-char or ":") *)) + (after-ncname + (xmltok+ (xmltok-g ncname-nmtoken + ":" (xmltok-p nmtoken-after-colon)) + or (xmltok-p (xmltok-g colon ":" ncname) + (xmltok-g colon-name-occur "[?+*]") opt) + or (xmltok-g ncname-occur "[?+*]") + or (xmltok-g ncname-colon ":"))) + (starts-with-name + (xmltok-g name ncname (xmltok-p after-ncname) opt)) + (starts-with-hash + (xmltok-g pound + "#" (xmltok-g hash-name ncname))) + (markup-declaration + (xmltok-g markup-declaration + "!" (xmltok-p (xmltok-g comment-first-dash "-" + (xmltok-g comment-open "-") opt) + or (xmltok-g named-markup-declaration + ncname)) opt)) + (after-lt + (xmltok+ markup-declaration + or (xmltok-g processing-instruction-question + question) + or (xmltok-g instance-start + ncname))) + (starts-with-lt (xmltok-g less-than "<" (xmltok-p after-lt) opt))) + (xmltok+ starts-with-lt + or single-char + or starts-with-close-paren + or starts-with-percent + or starts-with-name + or starts-with-nmtoken-not-name + or starts-with-hash + or internal-subset-close))))) + +(defconst xmltok-ncname-regexp (xmltok-ncname regexp)) + +(defun xmltok-scan-after-lt () + (cond ((not (looking-at (xmltok-after-lt regexp))) + (xmltok-add-error "`<' that is not markup must be entered as `<'") + (setq xmltok-type 'not-well-formed)) + (t + (goto-char (match-end 0)) + (cond ((xmltok-after-lt start start-tag-close) + (setq xmltok-name-end + (xmltok-after-lt end start-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start start-tag-colon)) + (setq xmltok-attributes nil) + (setq xmltok-namespace-attributes nil) + (setq xmltok-type 'start-tag)) + ((xmltok-after-lt start end-tag-close) + (setq xmltok-name-end + (xmltok-after-lt end end-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start end-tag-colon)) + (setq xmltok-type 'end-tag)) + ((xmltok-after-lt start start-tag-s) + (setq xmltok-name-end + (xmltok-after-lt end start-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start start-tag-colon)) + (setq xmltok-namespace-attributes nil) + (setq xmltok-attributes nil) + (xmltok-scan-attributes) + xmltok-type) + ((xmltok-after-lt start empty-tag-close) + (setq xmltok-name-end + (xmltok-after-lt end start-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start start-tag-colon)) + (setq xmltok-attributes nil) + (setq xmltok-namespace-attributes nil) + (setq xmltok-type 'empty-element)) + ((xmltok-after-lt start cdata-section-open) + (setq xmltok-type + (if (search-forward "]]>" nil t) + 'cdata-section + (xmltok-add-error "No closing ]]>") + (xmltok-add-dependent 'xmltok-unclosed-reparse-p + nil + nil + "]]>") + 'not-well-formed))) + ((xmltok-after-lt start processing-instruction-question) + (xmltok-scan-after-processing-instruction-open)) + ((xmltok-after-lt start comment-open) + (xmltok-scan-after-comment-open)) + ((xmltok-after-lt start empty-tag-slash) + (setq xmltok-name-end + (xmltok-after-lt end start-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start start-tag-colon)) + (setq xmltok-attributes nil) + (setq xmltok-namespace-attributes nil) + (xmltok-add-error "Expected `/>'" (1- (point))) + (setq xmltok-type 'partial-empty-element)) + ((xmltok-after-lt start start-tag-name) + (xmltok-add-error "Missing `>'" + nil + (1+ xmltok-start)) + (setq xmltok-name-end + (xmltok-after-lt end start-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start start-tag-colon)) + (setq xmltok-namespace-attributes nil) + (setq xmltok-attributes nil) + (setq xmltok-type 'partial-start-tag)) + ((xmltok-after-lt start end-tag-name) + (setq xmltok-name-end (xmltok-after-lt end end-tag-name)) + (setq xmltok-name-colon + (xmltok-after-lt start end-tag-colon)) + (cond ((and (not xmltok-name-colon) + (eq (char-after) ?:)) + (goto-char (1+ (point))) + (xmltok-add-error "Expected name following `:'" + (1- (point)))) + (t + (xmltok-add-error "Missing `>'" + nil + (1+ xmltok-start)))) + (setq xmltok-type 'partial-end-tag)) + ((xmltok-after-lt start end-tag-slash) + (xmltok-add-error "Expected name following `</'") + (setq xmltok-name-end nil) + (setq xmltok-name-colon nil) + (setq xmltok-type 'partial-end-tag)) + ((xmltok-after-lt start marked-section-open) + (xmltok-add-error "Expected `CDATA[' after `<!['" + xmltok-start + (+ 3 xmltok-start)) + (setq xmltok-type 'not-well-formed)) + ((xmltok-after-lt start comment-first-dash) + (xmltok-add-error "Expected `-' after `<!-'" + xmltok-start + (+ 3 xmltok-start)) + (setq xmltok-type 'not-well-formed)) + ((xmltok-after-lt start markup-declaration) + (xmltok-add-error "Expected `[CDATA[' or `--' after `<!'" + xmltok-start + (+ 2 xmltok-start)) + (setq xmltok-type 'not-well-formed)) + (t + (xmltok-add-error "Not well-formed") + (setq xmltok-type 'not-well-formed)))))) + +;; XXX This should be unified with +;; xmltok-scan-prolog-after-processing-instruction-open +;; XXX maybe should include rest of line (up to any <,>) in unclosed PI +(defun xmltok-scan-after-processing-instruction-open () + (cond ((not (search-forward "?>" nil t)) + (xmltok-add-error "No closing ?>" + xmltok-start + (+ xmltok-start 2)) + (xmltok-add-dependent 'xmltok-unclosed-reparse-p + nil + nil + "?>") + (setq xmltok-type 'not-well-formed)) + (t + (cond ((not (save-excursion + (goto-char (+ 2 xmltok-start)) + (and (looking-at (xmltok-ncname regexp)) + (setq xmltok-name-end (match-end 0))))) + (setq xmltok-name-end (+ xmltok-start 2)) + (xmltok-add-error "<? not followed by name" + (+ xmltok-start 2) + (+ xmltok-start 3))) + ((not (or (memq (char-after xmltok-name-end) + '(?\n ?\t ?\r ? )) + (= xmltok-name-end (- (point) 2)))) + (xmltok-add-error "Target not followed by whitespace" + xmltok-name-end + (1+ xmltok-name-end))) + ((and (= xmltok-name-end (+ xmltok-start 5)) + (save-excursion + (goto-char (+ xmltok-start 2)) + (let ((case-fold-search t)) + (looking-at "xml")))) + (xmltok-add-error "Processing instruction target is xml" + (+ xmltok-start 2) + (+ xmltok-start 5)))) + (setq xmltok-type 'processing-instruction)))) + +(defun xmltok-scan-after-comment-open () + (setq xmltok-type + (cond ((not (search-forward "--" nil t)) + (xmltok-add-error "No closing -->") + (xmltok-add-dependent 'xmltok-unclosed-reparse-p + nil + nil + ;; not --> because + ;; -- is not allowed + ;; in comments in XML + "--") + 'not-well-formed) + ((eq (char-after) ?>) + (goto-char (1+ (point))) + 'comment) + (t + (xmltok-add-dependent + 'xmltok-semi-closed-reparse-p + nil + (point) + "--" + 2) + ;; just include the <!-- in the token + (goto-char (+ xmltok-start 4)) + ;; Need do this after the goto-char because + ;; marked error should just apply to <!-- + (xmltok-add-error "First following `--' not followed by `>'") + 'not-well-formed)))) + +(defun xmltok-scan-attributes () + (let ((recovering nil) + (atts-needing-normalization nil)) + (while (cond ((or (looking-at (xmltok-attribute regexp)) + ;; use non-greedy group + (when (looking-at (concat "[^<>\n]+?" + (xmltok-attribute regexp))) + (unless recovering + (xmltok-add-error "Malformed attribute" + (point) + (save-excursion + (goto-char (xmltok-attribute start + name)) + (skip-chars-backward "\r\n\t ") + (point)))) + t)) + (setq recovering nil) + (goto-char (match-end 0)) + (let ((att (xmltok-add-attribute))) + (when att + (setq atts-needing-normalization + (cons att atts-needing-normalization)))) + (cond ((xmltok-attribute start start-tag-s) t) + ((xmltok-attribute start start-tag-close) + (setq xmltok-type 'start-tag) + nil) + ((xmltok-attribute start empty-tag-close) + (setq xmltok-type 'empty-element) + nil) + ((xmltok-attribute start empty-tag-slash) + (setq xmltok-type 'partial-empty-element) + (xmltok-add-error "Expected `/>'" + (1- (point))) + nil) + ((looking-at "[ \t\r\n]*[\"']") + (goto-char (match-end 0)) + (xmltok-add-error "Missing closing delimiter" + (1- (point))) + (setq recovering t) + t) + ((looking-at "[ \t]*\\([^ \t\r\n\"'=<>/]+\\)[ \t\r\n/>]") + (goto-char (match-end 1)) + (xmltok-add-error "Attribute value not quoted" + (match-beginning 1)) + (setq recovering t) + t) + (t + (xmltok-add-error "Missing attribute value" + (1- (point))) + (setq recovering t) + t))) + ((looking-at "[^<>\n]*/>") + (let ((start (point))) + (goto-char (match-end 0)) + (unless recovering + (xmltok-add-error "Malformed empty-element" + start + (- (point) 2)))) + (setq xmltok-type 'empty-element) + nil) + ((looking-at "[^<>\n]*>") + (let ((start (point))) + (goto-char (match-end 0)) + (unless recovering + (xmltok-add-error "Malformed start-tag" + start + (1- (point))))) + (setq xmltok-type 'start-tag) + nil) + (t + (when recovering + (skip-chars-forward "^<>\n")) + (xmltok-add-error "Missing `>'" + xmltok-start + (1+ xmltok-start)) + (setq xmltok-type 'partial-start-tag) + nil))) + (while atts-needing-normalization + (xmltok-normalize-attribute (car atts-needing-normalization)) + (setq atts-needing-normalization (cdr atts-needing-normalization)))) + (setq xmltok-attributes + (nreverse xmltok-attributes)) + (setq xmltok-namespace-attributes + (nreverse xmltok-namespace-attributes))) + +(defun xmltok-add-attribute () + "Return the attribute if it needs normalizing, otherwise nil." + (let* ((needs-normalizing nil) + (att + (if (xmltok-attribute start literal) + (progn + (setq needs-normalizing + (or (xmltok-attribute start complex1) + (xmltok-attribute start complex2))) + (xmltok-make-attribute (xmltok-attribute start name) + (xmltok-attribute start colon) + (xmltok-attribute end name) + (1+ (xmltok-attribute start literal)) + (1- (xmltok-attribute end literal)) + (not needs-normalizing))) + (xmltok-make-attribute (xmltok-attribute start name) + (xmltok-attribute start colon) + (xmltok-attribute end name))))) + (if (xmltok-attribute start xmlns) + (setq xmltok-namespace-attributes + (cons att xmltok-namespace-attributes)) + (setq xmltok-attributes + (cons att xmltok-attributes))) + (and needs-normalizing + att))) + +(defun xmltok-normalize-attribute (att) + (let ((end (xmltok-attribute-value-end att)) + (well-formed t) + (value-parts nil) + (refs nil)) + (save-excursion + (goto-char (xmltok-attribute-value-start att)) + (while (progn + (let ((n (skip-chars-forward "^\r\t\n&" end))) + (when (> n 0) + (setq value-parts + (cons (buffer-substring-no-properties (- (point) n) + (point)) + value-parts)))) + (when (< (point) end) + (goto-char (1+ (point))) + (cond ((eq (char-before) ?\&) + (let ((xmltok-start (1- (point))) + xmltok-type xmltok-replacement) + (xmltok-scan-after-amp + (lambda (start end) + (xmltok-handle-entity start end t))) + (cond ((or (eq xmltok-type 'char-ref) + (eq xmltok-type 'entity-ref)) + (setq refs + (cons (vector xmltok-type + xmltok-start + (point)) + refs)) + (if xmltok-replacement + (setq value-parts + (cons xmltok-replacement + value-parts)) + (setq well-formed nil))) + (t (setq well-formed nil))))) + (t (setq value-parts + (cons " " value-parts))))) + (< (point) end)))) + (when well-formed + (aset att 5 (apply 'concat (nreverse value-parts)))) + (aset att 6 (nreverse refs)))) + +(defun xmltok-scan-after-amp (entity-handler) + (cond ((not (looking-at (xmltok-after-amp regexp))) + (xmltok-add-error "`&' that is not markup must be entered as `&'") + (setq xmltok-type 'not-well-formed)) + (t + (goto-char (match-end 0)) + (cond ((xmltok-after-amp start entity-ref-close) + (funcall entity-handler + (xmltok-after-amp start entity-name) + (xmltok-after-amp end entity-name)) + (setq xmltok-type 'entity-ref)) + ((xmltok-after-amp start decimal-ref-close) + (xmltok-scan-char-ref (xmltok-after-amp start decimal) + (xmltok-after-amp end decimal) + 10)) + ((xmltok-after-amp start hex-ref-close) + (xmltok-scan-char-ref (xmltok-after-amp start hex) + (xmltok-after-amp end hex) + 16)) + ((xmltok-after-amp start number-sign) + (xmltok-add-error "Missing character number") + (setq xmltok-type 'not-well-formed)) + (t + (xmltok-add-error "Missing closing `;'") + (setq xmltok-type 'not-well-formed)))))) + +(defconst xmltok-entity-error-messages + '((unparsed . "Referenced entity is unparsed") + (not-well-formed . "Referenced entity is not well-formed") + (external nil . "Referenced entity is external") + (element nil . "Referenced entity contains <"))) + +(defun xmltok-handle-entity (start end &optional attributep) + (let* ((name (buffer-substring-no-properties start end)) + (name-def (assoc name xmltok-dtd)) + (def (cdr name-def))) + (cond ((setq xmltok-replacement (and (consp def) + (if attributep + (cdr def) + (car def))))) + ((null name-def) + (unless (eq (car xmltok-dtd) t) + (xmltok-add-error "Referenced entity has not been defined" + start + end))) + ((and attributep (consp def)) + (xmltok-add-error "Referenced entity contains <" + start + end)) + (t + (let ((err (cdr (assq def xmltok-entity-error-messages)))) + (when (consp err) + (setq err (if attributep (cdr err) (car err)))) + (when err + (xmltok-add-error err start end))))))) + +(defun xmltok-scan-char-ref (start end base) + (setq xmltok-replacement + (let ((n (string-to-number (buffer-substring-no-properties start end) + base))) + (cond ((and (integerp n) (xmltok-valid-char-p n)) + (setq n (xmltok-unicode-to-char n)) + (and n (string n))) + (t + (xmltok-add-error "Invalid character code" start end) + nil)))) + (setq xmltok-type 'char-ref)) + +(defun xmltok-char-number (start end) + (let* ((base (if (eq (char-after (+ start 2)) ?x) + 16 + 10)) + (n (string-to-number + (buffer-substring-no-properties (+ start (if (= base 16) 3 2)) + (1- end)) + base))) + (and (integerp n) + (xmltok-valid-char-p n) + n))) + +(defun xmltok-unclosed-reparse-p (change-start + change-end + pre-change-length + start + end + delimiter) + (let ((len-1 (1- (length delimiter)))) + (goto-char (max start (- change-start len-1))) + (search-forward delimiter (min end (+ change-end len-1)) t))) + +;; Handles a <!-- with the next -- not followed by > + +(defun xmltok-semi-closed-reparse-p (change-start + change-end + pre-change-length + start + end + delimiter + delimiter-length) + (or (<= (- end delimiter-length) change-end) + (xmltok-unclosed-reparse-p change-start + change-end + pre-change-length + start + end + delimiter))) + +(defun xmltok-valid-char-p (n) + "Return non-nil if n is the Unicode code of a valid XML character." + (cond ((< n #x20) (memq n '(#xA #xD #x9))) + ((< n #xD800) t) + ((< n #xE000) nil) + ((< n #xFFFE) t) + (t (and (> n #xFFFF) + (< n #x110000))))) + +(defun xmltok-unicode-to-char (n) + "Return the character corresponding to Unicode scalar value N. +Return nil if unsupported in Emacs." + (decode-char 'ucs n)) + +;;; Prolog parsing + +(defvar xmltok-contains-doctype nil) +(defvar xmltok-doctype-external-subset-flag nil) +(defvar xmltok-internal-subset-start nil) +(defvar xmltok-had-param-entity-ref nil) +(defvar xmltok-prolog-regions nil) +(defvar xmltok-standalone nil + "Non-nil if there was an XML declaration specifying standalone=\"yes\",") +(defvar xmltok-markup-declaration-doctype-flag nil) + +(defconst xmltok-predefined-entity-alist + '(("lt" "<" . "<") + ("gt" ">" . ">") + ("amp" "&" . "&") + ("apos" "'" . "'") + ("quot" "\"" . "\""))) + +(defun xmltok-forward-prolog () + "Move forward to the end of the XML prolog. + +Returns a list of vectors [TYPE START END] where TYPE is a symbol and +START and END are integers giving the start and end of the region of +that type. TYPE can be one of xml-declaration, +xml-declaration-attribute-name, xml-declaration-attribute-value, +comment, processing-instruction-left, processing-instruction-right, +markup-declaration-open. markup-declaration-close, +internal-subset-open, internal-subset-close, hash-name, keyword, +literal, encoding-name. +Adds to `xmltok-errors' and `xmltok-dependent-regions' as appropriate." + (let ((case-fold-search nil) + xmltok-start + xmltok-type + xmltok-prolog-regions + xmltok-contains-doctype + xmltok-internal-subset-start + xmltok-had-param-entity-ref + xmltok-standalone + xmltok-doctype-external-subset-flag + xmltok-markup-declaration-doctype-flag) + (setq xmltok-dtd xmltok-predefined-entity-alist) + (xmltok-scan-xml-declaration) + (xmltok-next-prolog-token) + (while (condition-case err + (when (xmltok-parse-prolog-item) + (xmltok-next-prolog-token)) + (xmltok-markup-declaration-parse-error + (xmltok-skip-markup-declaration)))) + (when xmltok-internal-subset-start + (xmltok-add-error "No closing ]" + (1- xmltok-internal-subset-start) + xmltok-internal-subset-start)) + (xmltok-parse-entities) + ;; XXX prune dependent-regions for those entirely in prolog + (nreverse xmltok-prolog-regions))) + +(defconst xmltok-bad-xml-decl-regexp + "[ \t\r\n]*<\\?xml\\(?:[ \t\r\n]\\|\\?>\\)") + +;;;###autoload +(defun xmltok-get-declared-encoding-position (&optional limit) + "Return the position of the encoding in the XML declaration at point. +If there is a well-formed XML declaration starting at point and it +contains an encoding declaration, then return (START . END) +where START and END are the positions of the start and the end +of the encoding name; if there is no encoding declaration return +the position where and encoding declaration could be inserted. +If there is XML that is not well-formed that looks like an XML declaration, +return nil. Otherwise, return t. +If LIMIT is non-nil, then do not consider characters beyond LIMIT." + (cond ((let ((case-fold-search nil)) + (and (looking-at (xmltok-xml-declaration regexp)) + (or (not limit) (<= (match-end 0) limit)))) + (let ((end (xmltok-xml-declaration end encoding-value))) + (if end + (cons (1+ (xmltok-xml-declaration start encoding-value)) + (1- end)) + (or (xmltok-xml-declaration end version-value) + (+ (point) 5))))) + ((not (let ((case-fold-search t)) + (looking-at xmltok-bad-xml-decl-regexp)))))) + +(defun xmltok-scan-xml-declaration () + (when (looking-at (xmltok-xml-declaration regexp)) + (xmltok-add-prolog-region 'xml-declaration (point) (match-end 0)) + (goto-char (match-end 0)) + (when (xmltok-xml-declaration start version-name) + (xmltok-add-prolog-region 'xml-declaration-attribute-name + (xmltok-xml-declaration start version-name) + (xmltok-xml-declaration end version-name)) + (let ((start (xmltok-xml-declaration start version-value)) + (end (xmltok-xml-declaration end version-value))) + (xmltok-add-prolog-region 'xml-declaration-attribute-value + start + end))) + ;; XXX need to check encoding name + ;; Should start with letter, not contain colon + (when (xmltok-xml-declaration start encoding-name) + (xmltok-add-prolog-region 'xml-declaration-attribute-name + (xmltok-xml-declaration start encoding-name) + (xmltok-xml-declaration end encoding-name)) + (let ((start (xmltok-xml-declaration start encoding-value)) + (end (xmltok-xml-declaration end encoding-value))) + (xmltok-add-prolog-region 'encoding-name + (1+ start) + (1- end)) + (xmltok-add-prolog-region 'xml-declaration-attribute-value + start + end))) + (when (xmltok-xml-declaration start standalone-name) + (xmltok-add-prolog-region 'xml-declaration-attribute-name + (xmltok-xml-declaration start standalone-name) + (xmltok-xml-declaration end standalone-name)) + (let ((start (xmltok-xml-declaration start standalone-value)) + (end (xmltok-xml-declaration end standalone-value))) + (xmltok-add-prolog-region 'xml-declaration-attribute-value + start + end) + (setq xmltok-standalone + (string= (buffer-substring-no-properties (1+ start) (1- end)) + "yes")))) + t)) + +(defconst xmltok-markup-declaration-alist + '(("ELEMENT" . xmltok-parse-element-declaration) + ("ATTLIST" . xmltok-parse-attlist-declaration) + ("ENTITY" . xmltok-parse-entity-declaration) + ("NOTATION" . xmltok-parse-notation-declaration))) + +(defun xmltok-parse-prolog-item () + (cond ((eq xmltok-type 'comment) + (xmltok-add-prolog-region 'comment + xmltok-start + (point)) + t) + ((eq xmltok-type 'processing-instruction)) + ((eq xmltok-type 'named-markup-declaration) + (setq xmltok-markup-declaration-doctype-flag nil) + (xmltok-add-prolog-region 'markup-declaration-open + xmltok-start + (point)) + (let* ((name (buffer-substring-no-properties + (+ xmltok-start 2) + (point))) + (fun (cdr (assoc name xmltok-markup-declaration-alist)))) + (cond (fun + (unless xmltok-internal-subset-start + (xmltok-add-error + "Declaration allowed only in internal subset")) + (funcall fun)) + ((string= name "DOCTYPE") + (xmltok-parse-doctype)) + (t + (xmltok-add-error "Unknown markup declaration" + (+ xmltok-start 2)) + (xmltok-next-prolog-token) + (xmltok-markup-declaration-parse-error)))) + t) + ((or (eq xmltok-type 'end-prolog) + (not xmltok-type)) + nil) + ((eq xmltok-type 'internal-subset-close) + (xmltok-add-prolog-region 'internal-subset-close + xmltok-start + (1+ xmltok-start)) + (xmltok-add-prolog-region 'markup-declaration-close + (1- (point)) + (point)) + (if xmltok-internal-subset-start + (setq xmltok-internal-subset-start nil) + (xmltok-add-error "]> outside internal subset")) + t) + ((eq xmltok-type 'param-entity-ref) + (if xmltok-internal-subset-start + (setq xmltok-had-param-entity-ref t) + (xmltok-add-error "Parameter entity reference outside document type declaration")) + t) + ;; If we don't do this, we can get thousands of errors when + ;; a plain text file is parsed. + ((not xmltok-internal-subset-start) + (when (let ((err (car xmltok-errors))) + (or (not err) + (<= (xmltok-error-end err) xmltok-start))) + (goto-char xmltok-start)) + nil) + ((eq xmltok-type 'not-well-formed) t) + (t + (xmltok-add-error "Token allowed only inside markup declaration") + t))) + +(defun xmltok-parse-doctype () + (setq xmltok-markup-declaration-doctype-flag t) + (xmltok-next-prolog-token) + (when xmltok-internal-subset-start + (xmltok-add-error "DOCTYPE declaration not allowed in internal subset") + (xmltok-markup-declaration-parse-error)) + (when xmltok-contains-doctype + (xmltok-add-error "Duplicate DOCTYPE declaration") + (xmltok-markup-declaration-parse-error)) + (setq xmltok-contains-doctype t) + (xmltok-require-token 'name 'prefixed-name) + (xmltok-require-next-token "SYSTEM" "PUBLIC" ?\[ ?>) + (cond ((eq xmltok-type ?\[) + (setq xmltok-internal-subset-start (point))) + ((eq xmltok-type ?>)) + (t + (setq xmltok-doctype-external-subset-flag t) + (xmltok-parse-external-id) + (xmltok-require-token ?\[ ?>) + (when (eq xmltok-type ?\[) + (setq xmltok-internal-subset-start (point)))))) + +(defun xmltok-parse-attlist-declaration () + (xmltok-require-next-token 'prefixed-name 'name) + (while (progn + (xmltok-require-next-token ?> 'name 'prefixed-name) + (if (eq xmltok-type ?>) + nil + (xmltok-require-next-token ?\( + "CDATA" + "ID" + "IDREF" + "IDREFS" + "ENTITY" + "ENTITIES" + "NMTOKEN" + "NMTOKENS" + "NOTATION") + (cond ((eq xmltok-type ?\() + (xmltok-parse-nmtoken-group)) + ((string= (xmltok-current-token-string) + "NOTATION") + (xmltok-require-next-token ?\() + (xmltok-parse-nmtoken-group))) + (xmltok-require-next-token "#IMPLIED" + "#REQUIRED" + "#FIXED" + 'literal) + (when (string= (xmltok-current-token-string) "#FIXED") + (xmltok-require-next-token 'literal)) + t)))) + +(defun xmltok-parse-nmtoken-group () + (while (progn + (xmltok-require-next-token 'nmtoken 'prefixed-name 'name) + (xmltok-require-next-token ?| ?\)) + (eq xmltok-type ?|)))) + +(defun xmltok-parse-element-declaration () + (xmltok-require-next-token 'name 'prefixed-name) + (xmltok-require-next-token "EMPTY" "ANY" ?\() + (when (eq xmltok-type ?\() + (xmltok-require-next-token "#PCDATA" + 'name + 'prefixed-name + 'name-occur + ?\() + (cond ((eq xmltok-type 'hash-name) + (xmltok-require-next-token ?| ?\) 'close-paren-star) + (while (eq xmltok-type ?|) + (xmltok-require-next-token 'name 'prefixed-name) + (xmltok-require-next-token 'close-paren-star ?|))) + (t (xmltok-parse-model-group)))) + (xmltok-require-next-token ?>)) + +(defun xmltok-parse-model-group () + (xmltok-parse-model-group-member) + (xmltok-require-next-token ?| + ?, + ?\) + 'close-paren-star + 'close-paren-occur) + (when (memq xmltok-type '(?, ?|)) + (let ((connector xmltok-type)) + (while (progn + (xmltok-next-prolog-token) + (xmltok-parse-model-group-member) + (xmltok-require-next-token connector + ?\) + 'close-paren-star + 'close-paren-occur) + (eq xmltok-type connector)))))) + +(defun xmltok-parse-model-group-member () + (xmltok-require-token 'name + 'prefixed-name + 'name-occur + ?\() + (when (eq xmltok-type ?\() + (xmltok-next-prolog-token) + (xmltok-parse-model-group))) + +(defun xmltok-parse-entity-declaration () + (let (paramp name) + (xmltok-require-next-token 'name ?%) + (when (eq xmltok-type ?%) + (setq paramp t) + (xmltok-require-next-token 'name)) + (setq name (xmltok-current-token-string)) + (xmltok-require-next-token 'literal "SYSTEM" "PUBLIC") + (cond ((eq xmltok-type 'literal) + (let ((replacement (xmltok-parse-entity-value))) + (unless paramp + (xmltok-define-entity name replacement))) + (xmltok-require-next-token ?>)) + (t + (xmltok-parse-external-id) + (if paramp + (xmltok-require-token ?>) + (xmltok-require-token ?> "NDATA") + (if (eq xmltok-type ?>) + (xmltok-define-entity name 'external) + (xmltok-require-next-token 'name) + (xmltok-require-next-token ?>) + (xmltok-define-entity name 'unparsed))))))) + +(defun xmltok-define-entity (name value) + (when (and (or (not xmltok-had-param-entity-ref) + xmltok-standalone) + (not (assoc name xmltok-dtd))) + (setq xmltok-dtd + (cons (cons name value) xmltok-dtd)))) + +(defun xmltok-parse-entity-value () + (let ((lim (1- (point))) + (well-formed t) + value-parts + start) + (save-excursion + (goto-char (1+ xmltok-start)) + (setq start (point)) + (while (progn + (skip-chars-forward "^%&" lim) + (when (< (point) lim) + (goto-char (1+ (point))) + (cond ((eq (char-before) ?%) + (xmltok-add-error "Parameter entity references are not allowed in the internal subset" + (1- (point)) + (point)) + (setq well-formed nil)) + (t + (let ((xmltok-start (1- (point))) + xmltok-type xmltok-replacement) + (xmltok-scan-after-amp (lambda (start end))) + (cond ((eq xmltok-type 'char-ref) + (setq value-parts + (cons (buffer-substring-no-properties + start + xmltok-start) + value-parts)) + (setq value-parts + (cons xmltok-replacement + value-parts)) + (setq start (point))) + ((eq xmltok-type 'not-well-formed) + (setq well-formed nil)))))) + t)))) + (if (not well-formed) + nil + (apply 'concat + (nreverse (cons (buffer-substring-no-properties start lim) + value-parts)))))) + +(defun xmltok-parse-notation-declaration () + (xmltok-require-next-token 'name) + (xmltok-require-next-token "SYSTEM" "PUBLIC") + (let ((publicp (string= (xmltok-current-token-string) "PUBLIC"))) + (xmltok-require-next-token 'literal) + (cond (publicp + (xmltok-require-next-token 'literal ?>) + (unless (eq xmltok-type ?>) + (xmltok-require-next-token ?>))) + (t (xmltok-require-next-token ?>))))) + +(defun xmltok-parse-external-id () + (xmltok-require-token "SYSTEM" "PUBLIC") + (let ((publicp (string= (xmltok-current-token-string) "PUBLIC"))) + (xmltok-require-next-token 'literal) + (when publicp + (xmltok-require-next-token 'literal))) + (xmltok-next-prolog-token)) + +(defun xmltok-require-next-token (&rest types) + (xmltok-next-prolog-token) + (apply 'xmltok-require-token types)) + +(defun xmltok-require-token (&rest types) + ;; XXX Generate a more helpful error message + (while (and (not (let ((type (car types))) + (if (stringp (car types)) + (string= (xmltok-current-token-string) type) + (eq type xmltok-type)))) + (setq types (cdr types)))) + (unless types + (when (and xmltok-type + (not (eq xmltok-type 'not-well-formed))) + (xmltok-add-error "Unexpected token")) + (xmltok-markup-declaration-parse-error)) + (let ((region-type (xmltok-prolog-region-type (car types)))) + (when region-type + (xmltok-add-prolog-region region-type + xmltok-start + (point))))) + +(defun xmltok-current-token-string () + (buffer-substring-no-properties xmltok-start (point))) + +(put 'xmltok-markup-declaration-parse-error + 'error-conditions + '(error xmltok-markup-declaration-parse-error)) + +(put 'xmltok-markup-declaration-parse-error + 'error-message + "Syntax error in markup declaration") + +(defun xmltok-markup-declaration-parse-error () + (signal 'xmltok-markup-declaration-parse-error nil)) + +(defun xmltok-skip-markup-declaration () + (while (cond ((eq xmltok-type ?>) + (xmltok-next-prolog-token) + nil) + ((and xmltok-markup-declaration-doctype-flag + (eq xmltok-type ?\[)) + (setq xmltok-internal-subset-start (point)) + (xmltok-next-prolog-token) + nil) + ((memq xmltok-type '(nil + end-prolog + named-markup-declaration + comment + processing-instruction)) + nil) + ((and xmltok-internal-subset-start + (eq xmltok-type 'internal-subset-close)) + nil) + (t (xmltok-next-prolog-token) t))) + xmltok-type) + +(defun xmltok-prolog-region-type (required) + (cond ((cdr (assq xmltok-type + '((literal . literal) + (?> . markup-declaration-close) + (?\[ . internal-subset-open) + (hash-name . hash-name))))) + ((and (stringp required) (eq xmltok-type 'name)) + 'keyword))) + +;; Return new token type. + +(defun xmltok-next-prolog-token () + (skip-chars-forward " \t\r\n") + (setq xmltok-start (point)) + (cond ((not (and (looking-at (xmltok-prolog regexp)) + (goto-char (match-end 0)))) + (let ((ch (char-after))) + (cond (ch + (goto-char (1+ (point))) + (xmltok-add-error "Illegal char in prolog") + (setq xmltok-type 'not-well-formed)) + (t (setq xmltok-type nil))))) + ((or (xmltok-prolog start ncname-occur) + (xmltok-prolog start colon-name-occur)) + (setq xmltok-name-end (1- (point))) + (setq xmltok-name-colon (xmltok-prolog start colon)) + (setq xmltok-type 'name-occur)) + ((xmltok-prolog start colon) + (setq xmltok-name-end (point)) + (setq xmltok-name-colon (xmltok-prolog start colon)) + (unless (looking-at "[ \t\r\n>),|[%]") + (xmltok-add-error "Missing space after name")) + (setq xmltok-type 'prefixed-name)) + ((or (xmltok-prolog start ncname-nmtoken) + (xmltok-prolog start ncname-colon)) + (unless (looking-at "[ \t\r\n>),|[%]") + (xmltok-add-error "Missing space after name token")) + (setq xmltok-type 'nmtoken)) + ((xmltok-prolog start name) + (setq xmltok-name-end (point)) + (setq xmltok-name-colon nil) + (unless (looking-at "[ \t\r\n>),|[%]") + (xmltok-add-error "Missing space after name")) + (setq xmltok-type 'name)) + ((xmltok-prolog start hash-name) + (setq xmltok-name-end (point)) + (unless (looking-at "[ \t\r\n>)|%]") + (xmltok-add-error "Missing space after name")) + (setq xmltok-type 'hash-name)) + ((xmltok-prolog start processing-instruction-question) + (xmltok-scan-prolog-after-processing-instruction-open)) + ((xmltok-prolog start comment-open) + ;; XXX if not-well-formed, ignore some stuff + (xmltok-scan-after-comment-open)) + ((xmltok-prolog start named-markup-declaration) + (setq xmltok-type 'named-markup-declaration)) + ((xmltok-prolog start instance-start) + (goto-char xmltok-start) + (setq xmltok-type 'end-prolog)) + ((xmltok-prolog start close-paren-star) + (setq xmltok-type 'close-paren-star)) + ((xmltok-prolog start close-paren-occur) + (setq xmltok-type 'close-paren-occur)) + ((xmltok-prolog start close-paren) + (unless (looking-at "[ \t\r\n>,|)]") + (xmltok-add-error "Missing space after )")) + (setq xmltok-type ?\))) + ((xmltok-prolog start single-char) + (let ((ch (char-before))) + (cond ((memq ch '(?\" ?\')) + (xmltok-scan-prolog-literal)) + (t (setq xmltok-type ch))))) + ((xmltok-prolog start percent) + (cond ((xmltok-prolog start param-entity-ref-close) + (setq xmltok-name-end (1- (point))) + (setq xmltok-type 'param-entity-ref)) + ((xmltok-prolog start param-entity-ref) + (xmltok-add-error "Missing ;") + (setq xmltok-name-end (point)) + (setq xmltok-type 'param-entity-ref)) + ((looking-at "[ \t\r\n%]") + (setq xmltok-type ?%)) + (t + (xmltok-add-error "Expected name after %") + (setq xmltok-type 'not-well-formed)))) + ((xmltok-prolog start nmtoken) + (unless (looking-at "[ \t\r\n>),|[%]") + (xmltok-add-error "Missing space after name token")) + (setq xmltok-type 'nmtoken)) + ((xmltok-prolog start internal-subset-close) + (setq xmltok-type 'internal-subset-close)) + ((xmltok-prolog start pound) + (xmltok-add-error "Expected name after #") + (setq xmltok-type 'not-well-formed)) + ((xmltok-prolog start markup-declaration) + (xmltok-add-error "Expected name or -- after <!") + (setq xmltok-type 'not-well-formed)) + ((xmltok-prolog start comment-first-dash) + (xmltok-add-error "Expected <!--") + (setq xmltok-type 'not-well-formed)) + ((xmltok-prolog start less-than) + (xmltok-add-error "Incomplete markup") + (setq xmltok-type 'not-well-formed)) + (t (error "Unhandled token in prolog %s" + (match-string-no-properties 0))))) + +(defun xmltok-scan-prolog-literal () + (let* ((delim (string (char-before))) + (safe-end (save-excursion + (skip-chars-forward (concat "^<>[]" delim)) + (point))) + (end (save-excursion + (goto-char safe-end) + (search-forward delim nil t)))) + (or (cond ((not end) + (xmltok-add-dependent 'xmltok-unclosed-reparse-p + nil + nil + delim) + nil) + ((save-excursion + (goto-char end) + (looking-at "[ \t\r\n>%[]")) + (goto-char end) + (setq xmltok-type 'literal)) + ((eq (1+ safe-end) end) + (goto-char end) + (xmltok-add-error (format "Missing space after %s" delim) + safe-end) + (setq xmltok-type 'literal)) + (t + (xmltok-add-dependent 'xmltok-semi-closed-reparse-p + xmltok-start + (1+ end) + delim + 1) + nil)) + (progn + (xmltok-add-error (format "Missing closing %s" delim)) + (goto-char safe-end) + (skip-chars-backward " \t\r\n") + (setq xmltok-type 'not-well-formed))))) + +(defun xmltok-scan-prolog-after-processing-instruction-open () + (cond ((not (search-forward "?>" nil t)) + (xmltok-add-error "No closing ?>" + xmltok-start + (+ xmltok-start 2)) + (xmltok-add-dependent 'xmltok-unclosed-reparse-p + nil + nil + "?>") + (setq xmltok-type 'not-well-formed)) + (t + (let* ((end (point)) + (target + (save-excursion + (goto-char (+ xmltok-start 2)) + (and (looking-at (xmltok-ncname regexp)) + (or (memq (char-after (match-end 0)) + '(?\n ?\t ?\r ? )) + (= (match-end 0) (- end 2))) + (match-string-no-properties 0))))) + (cond ((not target) + (xmltok-add-error "\ +Processing instruction does not start with a name" + (+ xmltok-start 2) + (+ xmltok-start 3))) + ((not (and (= (length target) 3) + (let ((case-fold-search t)) + (string-match "xml" target))))) + ((= xmltok-start 1) + (xmltok-add-error "Invalid XML declaration" + xmltok-start + (point))) + ((save-excursion + (goto-char xmltok-start) + (looking-at (xmltok-xml-declaration regexp))) + (xmltok-add-error "XML declaration not at beginning of file" + xmltok-start + (point))) + (t + (xmltok-add-error "Processing instruction has target of xml" + (+ xmltok-start 2) + (+ xmltok-start 5)))) + (xmltok-add-prolog-region 'processing-instruction-left + xmltok-start + (+ xmltok-start + 2 + (if target + (length target) + 0))) + (xmltok-add-prolog-region 'processing-instruction-right + (if target + (save-excursion + (goto-char (+ xmltok-start + (length target) + 2)) + (skip-chars-forward " \t\r\n") + (point)) + (+ xmltok-start 2)) + (point))) + (setq xmltok-type 'processing-instruction)))) + +(defun xmltok-parse-entities () + (let ((todo xmltok-dtd)) + (when (and (or xmltok-had-param-entity-ref + xmltok-doctype-external-subset-flag) + (not xmltok-standalone)) + (setq xmltok-dtd (cons t xmltok-dtd))) + (while todo + (xmltok-parse-entity (car todo)) + (setq todo (cdr todo))))) + +(defun xmltok-parse-entity (name-def) + (let ((def (cdr name-def)) + ;; in case its value is buffer local + (xmltok-dtd xmltok-dtd) + buf) + (when (stringp def) + (if (string-match "\\`[^&<\t\r\n]*\\'" def) + (setcdr name-def (cons def def)) + (setcdr name-def 'not-well-formed) ; avoid infinite expansion loops + (setq buf (get-buffer-create + (format " *Entity %s*" (car name-def)))) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert def) + (goto-char (point-min)) + (setcdr name-def + (xmltok-parse-entity-replacement))) + (kill-buffer buf))))) + +(defun xmltok-parse-entity-replacement () + (let ((def (cons "" ""))) + (while (let* ((start (point)) + (found (re-search-forward "[<&\t\r\n]\\|]]>" nil t)) + (ch (and found (char-before))) + (str (buffer-substring-no-properties + start + (if found + (match-beginning 0) + (point-max))))) + (setq def + (xmltok-append-entity-def def + (cons str str))) + (cond ((not found) nil) + ((eq ch ?>) + (setq def 'not-well-formed) + nil) + ((eq ch ?<) + (xmltok-save + (setq xmltok-start (1- (point))) + (xmltok-scan-after-lt) + (setq def + (xmltok-append-entity-def + def + (cond ((memq xmltok-type + '(start-tag + end-tag + empty-element)) + 'element) + ((memq xmltok-type + '(comment + processing-instruction)) + (cons "" nil)) + ((eq xmltok-type + 'cdata-section) + (cons (buffer-substring-no-properties + (+ xmltok-start 9) + (- (point) 3)) + nil)) + (t 'not-well-formed))))) + t) + ((eq ch ?&) + (let ((xmltok-start (1- (point))) + xmltok-type + xmltok-replacement + xmltok-errors) + (xmltok-scan-after-amp 'xmltok-handle-nested-entity) + (cond ((eq xmltok-type 'entity-ref) + (setq def + (xmltok-append-entity-def + def + xmltok-replacement))) + ((eq xmltok-type 'char-ref) + (setq def + (xmltok-append-entity-def + def + (if xmltok-replacement + (cons xmltok-replacement + xmltok-replacement) + (and xmltok-errors 'not-well-formed))))) + (t + (setq def 'not-well-formed)))) + t) + (t + (setq def + (xmltok-append-entity-def + def + (cons (match-string-no-properties 0) + " "))) + t)))) + def)) + +(defun xmltok-handle-nested-entity (start end) + (let* ((name-def (assoc (buffer-substring-no-properties start end) + xmltok-dtd)) + (def (cdr name-def))) + (when (stringp def) + (xmltok-parse-entity name-def) + (setq def (cdr name-def))) + (setq xmltok-replacement + (cond ((null name-def) + (if (eq (car xmltok-dtd) t) + nil + 'not-well-formed)) + ((eq def 'unparsed) 'not-well-formed) + (t def))))) + +(defun xmltok-append-entity-def (d1 d2) + (cond ((consp d1) + (if (consp d2) + (cons (concat (car d1) (car d2)) + (and (cdr d1) + (cdr d2) + (concat (cdr d1) (cdr d2)))) + d2)) + ((consp d2) d1) + (t + (let ((defs '(not-well-formed external element))) + (while (not (or (eq (car defs) d1) + (eq (car defs) d2))) + (setq defs (cdr defs))) + (car defs))))) + +(defun xmltok-add-prolog-region (type start end) + (setq xmltok-prolog-regions + (cons (vector type start end) + xmltok-prolog-regions))) + +(defun xmltok-merge-attributes () + "Return a list merging `xmltok-attributes' and 'xmltok-namespace-attributes'. +The members of the merged list are in order of occurrence in the +document. The list may share list structure with `xmltok-attributes' +and `xmltok-namespace-attributes'." + (cond ((not xmltok-namespace-attributes) + xmltok-attributes) + ((not xmltok-attributes) + xmltok-namespace-attributes) + (t + (let ((atts1 xmltok-attributes) + (atts2 xmltok-namespace-attributes) + merged) + (while (and atts1 atts2) + (cond ((< (xmltok-attribute-name-start (car atts1)) + (xmltok-attribute-name-start (car atts2))) + (setq merged (cons (car atts1) merged)) + (setq atts1 (cdr atts1))) + (t + (setq merged (cons (car atts2) merged)) + (setq atts2 (cdr atts2))))) + (setq merged (nreverse merged)) + (cond (atts1 (setq merged (nconc merged atts1))) + (atts2 (setq merged (nconc merged atts2)))) + merged)))) + +;;; Testing + +(defun xmltok-forward-test () + (interactive) + (if (xmltok-forward) + (message "Scanned %s" xmltok-type) + (message "Scanned nothing"))) + +(defun xmltok-next-prolog-token-test () + (interactive) + (if (xmltok-next-prolog-token) + (message "Scanned %s" + (if (integerp xmltok-type) + (string xmltok-type) + xmltok-type)) + (message "Scanned end of file"))) + +(provide 'xmltok) + +;; arch-tag: 747e5f3a-6fc3-4f8d-bd96-89f05aa99f5e +;;; xmltok.el ends here diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el new file mode 100644 index 00000000000..a698ce71e60 --- /dev/null +++ b/lisp/nxml/xsd-regexp.el @@ -0,0 +1,2124 @@ +;;; xsd-regexp.el --- translate W3C XML Schema regexps to Emacs regexps + +;; Copyright (C) 2003, 2007 Free Software Foundation, Inc. + +;; Author: James Clark +;; Keywords: XML, regexp + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This handles the regular expressions in the syntax defined by: +;; W3C XML Schema Part 2: Datatypes +;; <http://www.w3.org/TR/xmlschema-2/#regexs> +;; +;; The main entry point is `xsdre-translate'. +;; +;; The features of XSD regexps that make this non-trivial are: +;; +;; - \p{PROP} escape for matching characters that have various +;; Unicode-defined properties +;; - character class subtraction:, e.g. [\p{L}-[abc]] matches +;; any character in the L category other than a, b and c. +;; +;; We compute the set of Unicode characters denoted by each XSD +;; char-class as a list of ranges. The regexp generated for a +;; single escape can be large (several thousand characters). +;; +;; XSD has non-traditional rules about when characters must be +;; and can be quoted with \. These are quite different from +;; the Emacs rules. +;; +;; The semantics of XSD regexps are defined in terms of Unicode. +;; Non-Unicode characters are not allowed in regular expressions and +;; will not match against the generated regular expressions. A +;; Unicode character means a character in one of the Mule charsets +;; ascii, latin-iso8859-1, mule-unicode-0100-24ff, +;; mule-unicode-2500-33ff, mule-unicode-e000-ffff, eight-bit-control +;; or a character translateable to such a character (i.e a character +;; for which `encode-char' will return non-nil). +;; +;; Using unify-8859-on-decoding-mode is probably a good idea here +;; (and generally with XML and other Unicode-oriented formats). +;; +;; Unfortunately, this means that this package is currently useless +;; for CJK characters, since there's no mule-unicode charset for the +;; CJK ranges of Unicode. We should devise a workaround for this +;; until the fabled Unicode version of Emacs makes an appearance. + +;;; Code: + +(defun xsdre-translate (regexp) + "Translate a W3C XML Schema Datatypes regexp to an Emacs regexp. +Returns a string. REGEXP is a string. If REGEXP is not a valid XSD +regexp, signal an `xsdre-invalid-regexp' condition." + (xsdre-from-symbolic + (xsdre-to-symbolic regexp))) + +(defvar xsdre-test-history nil) + +(defun xsdre-test-regexp () + (interactive) + (while + (let* ((str (read-from-minibuffer "Regexp: " + nil + nil + nil + 'xsdre-test-history)) + (symbolic + (xsdre-to-symbolic str))) + (with-output-to-temp-buffer "*XSD Regexp Test*" + (princ "XSD regexp: ") + (princ str) + (princ "\n") + (princ "Symbolic: ") + (princ "\n") + (pp symbolic) + (princ "\n") + (princ "Emacs regexp: ") + (princ (xsdre-from-symbolic symbolic))) + t))) + +;;; Range lists + +(defsubst xsdre-make-range (first last) + "Return a representation of a range of integers. +If the range contains a single integer, it is represented by that integer. +Otherwise, it is represented by a (FIRST . LAST) pair." + (if (= first last) + first + (cons first last))) + +(defsubst xsdre-range-first (r) + "Return the first integer in a range." + (if (consp r) (car r) r)) + +(defsubst xsdre-range-last (r) + "Return the last integer in a range." + (if (consp r) (cdr r) r)) + +(defun xsdre-make-range-list (list) + "Make a range-list from a list of ranges. +A range-list represents a set of integers by a list of ranges in a +canonical form, in which ranges are in increasing order, and adjacent +ranges are merged wherever possible." + (when list + (setq list + (sort list 'xsdre-range-less-than)) + (let* ((next (cdr list)) + (tail list) + (head (car list)) + (first (xsdre-range-first head)) + (last (xsdre-range-last head))) + (while next + (setq head (car next)) + (when (> (xsdre-range-last head) last) + (if (<= (xsdre-range-first head) (1+ last)) + (setq last (xsdre-range-last head)) + (setcar tail (xsdre-make-range first last)) + (setcdr tail next) + (setq tail next) + (setq first (xsdre-range-first head)) + (setq last (xsdre-range-last head)))) + (setq next (cdr next))) + (setcar tail (xsdre-make-range first last)) + (setcdr tail nil) + list))) + + +(defun xsdre-range-list-union (range-lists) + "Return a range-list the union of a list of range-lists." + (xsdre-make-range-list (apply 'append range-lists))) + +(defun xsdre-range-list-difference (orig subtract) + "Return a range-list for the difference of two range-lists." + (when orig + (let (new head next first last) + (while orig + (setq head (car orig)) + (setq first (xsdre-range-first head)) + (setq last (xsdre-range-last head)) + (while (and subtract + (< (xsdre-range-last (car subtract)) first)) + (setq subtract (cdr subtract))) + (while (and subtract + (<= first last) + (<= (xsdre-range-first (car subtract)) last)) + (when (< first (xsdre-range-first (car subtract))) + (setq new + (cons (xsdre-make-range + first + (1- (xsdre-range-first (car subtract)))) + new))) + (if (< (xsdre-range-last (car subtract)) last) + (progn + (setq first (1+ (xsdre-range-last (car subtract)))) + (setq subtract (cdr subtract))) + (setq first (1+ last)))) + (when (<= first last) + (setq new (cons (xsdre-make-range first last) new))) + (setq orig (cdr orig))) + (nreverse new)))) + +(defun xsdre-range-less-than (r1 r2) + "Return non-nil if range R1 is less than range R2." + (or (< (xsdre-range-first r1) (xsdre-range-first r2)) + (and (= (xsdre-range-first r1) (xsdre-range-first r2)) + (< (xsdre-range-last r1) (xsdre-range-last r2))))) + +(defun xsdre-check-range-list (range-list) + "Check that range-list is a range-list. +Signal an error if it is not." + (let ((last nil)) + (while range-list + (unless (consp range-list) + (error "Range list not a list")) + (let ((head (car range-list))) + (unless (or (integerp head) + (and (consp head) + (integerp (car head)) + (integerp (cdr head)))) + (error "Bad range %s" head)) + (when (and last + (not (< (1+ last) (xsdre-range-first head)))) + (error "Ranges not strictly increasing")) + (setq last (xsdre-range-last head))) + (setq range-list (cdr range-list)))) + t) + +;;; Compiling symbolic regexps to Emacs regexps + +(defun xsdre-from-symbolic (re) + "Return an Emacs regexp for the symbolic regexp RE." + (apply 'concat + (nreverse (xsdre-compile-regexp re nil)))) + +(defun xsdre-compile-regexp (re accum) + "Return a Emacs regular expression for the symbolic regexp RE. +Returns a list of strings whose head is the regexp for RE +and whose tail is ACCUM." + (cond ((not (consp re)) + (xsdre-compile-char-class re accum)) + ((eq (car re) 'choice) + (setq accum (cons "\\(?:" accum)) + (let ((choices (cdr re))) + (while choices + (setq accum + (xsdre-compile-regexp (car choices) + accum)) + (setq choices (cdr choices)) + (when choices + (setq accum + (cons "\\|" accum))))) + (cons "\\)" accum)) + ((eq (car re) 'sequence) + (let ((members (cdr re))) + (while members + (setq accum (xsdre-compile-regexp (car members) + accum)) + (setq members (cdr members)))) + accum) + ((eq (car re) 'repeat) + (let* ((sub (nth 1 re)) + (lower (nth 2 re)) + (upper (nth 3 re)) + (need-paren (and (consp sub) + (eq (car sub) 'sequence)))) + (when need-paren + (setq accum (cons "\\(?:" accum))) + (setq accum + (xsdre-compile-regexp sub accum)) + (when need-paren + (setq accum (cons "\\)" accum))) + (cond ((not upper) + (cond ((eq lower 0) + (cons "*" accum)) + ((eq lower 1) + (cons "+" accum)) + (t + (cons (concat "\\{" + (number-to-string lower) + ",\\}") + accum)))) + ((eq lower upper) + (cons (concat "\\{" + (number-to-string lower) + "\\}") + accum)) + ((and (eq lower 0) (eq upper 1)) + (cons "?" accum)) + (t + (cons (concat "\\{" + (number-to-string lower) + "," + (number-to-string upper) + "\\}") + accum))))) + (t (xsdre-compile-char-class re accum)))) + +(defun xsdre-compile-char-class (cc accum) + "Return a Emacs regular expression for the symbolic character class CC. +Returns a list of strings whose head is the regexp for CC +and whose tail is ACCUM." + (cons (if (integerp cc) + (xsdre-compile-single-char cc) + (let ((ranges (xsdre-range-list-mule-intersection + (xsdre-char-class-to-range-list cc)))) + (cond ((null ranges) "\001-\000") + ((and (null (cdr ranges)) + (= (xsdre-range-first (car ranges)) + (xsdre-range-last (car ranges)))) + (xsdre-compile-single-char + (xsdre-range-first (car ranges)))) + (t (xsdre-range-list-to-char-alternative ranges))))) + accum)) + +(defun xsdre-compile-single-char (ch) + (if (memq ch '(?. ?* ?+ ?? ?\[ ?\] ?^ ?$ ?\\)) + (string ?\\ ch) + (string (decode-char 'ucs ch)))) + +(defun xsdre-char-class-to-range-list (cc) + "Return a range-list for a symbolic char-class." + (cond ((integerp cc) (list cc)) + ((symbolp cc) + (or (get cc 'xsdre-ranges) + (xsdre-char-class-to-range-list (get cc 'xsdre-char-class)))) + ((integerp (car cc)) + (if (= (car cc) (cdr cc)) + (car cc) + cc)) + ((eq (car cc) 'union) + (xsdre-range-list-union (mapcar 'xsdre-char-class-to-range-list + (cdr cc)))) + ((eq (car cc) 'difference) + (xsdre-range-list-difference + (xsdre-char-class-to-range-list (nth 1 cc)) + (xsdre-char-class-to-range-list (nth 2 cc)))) + ((eq (car cc) 'range) + (list (xsdre-make-range (nth 1 cc) (nth 2 cc)))) + (t (error "Internal error in XSD regexp compilation: \ +unknown char-class %s" cc)))) + +(defconst xsdre-mule-char-set-ranges + '((0 . 127) + (128 . 159) + (160 . 255) + (#x0100 . #x24ff) + (#x2500 . #x33ff) + (#xe000 . #xffff)) + "List of ranges for the Mule character sets containing Unicode characters.") + +(defun xsdre-range-list-mule-intersection (range-list) + "Return the intersection of RANGE-LIST with the mule-supported ranges. +Also split ranges so that no range spans more that one mule charset." + (when range-list + (let* ((char-set-ranges (cdr xsdre-mule-char-set-ranges)) + (mule-ranges nil) + (char-set-first (caar xsdre-mule-char-set-ranges)) + (char-set-last (cdar xsdre-mule-char-set-ranges)) + (range (car range-list)) + (first (xsdre-range-first range)) + (last (xsdre-range-last range))) + (setq range-list (cdr range-list)) + (while (progn + (cond ((> first last) + (if (null range-list) + nil + (setq range (car range-list)) + (setq first (xsdre-range-first range)) + (setq last (xsdre-range-last range)) + (setq range-list (cdr range-list)) + t)) + ((< char-set-last first) + (if (null char-set-ranges) + nil + (setq char-set-first (caar char-set-ranges)) + (setq char-set-last (cdar char-set-ranges)) + (setq char-set-ranges (cdr char-set-ranges)) + t)) + ((< first char-set-first) + (setq first char-set-first)) + ;; Now we know that + ;; first <= last + ;; first <= char-set-last + ;; first >= char-set-first + ((<= last char-set-last) + (setq mule-ranges + (cons (xsdre-make-range first last) + mule-ranges)) + (setq first (1+ last)) + t) + (t + (setq mule-ranges + (cons (xsdre-make-range first char-set-last) + mule-ranges)) + (setq first (1+ char-set-last)) + t)))) + (nreverse mule-ranges)))) + +(defun xsdre-range-list-to-char-alternative (range-list) + "Return a char alternative for a range-list. +RANGE-LIST must contain more than integer. +The char alternative is a string containing an Emacs regexp +consisting of a single char alternative delimited with []." + (let (range caret close-bracket hyphen chars first last) + (while range-list + (setq range (car range-list)) + (setq first (xsdre-range-first range)) + (setq last (xsdre-range-last range)) + (while (and (cond ((eq first ?^) + (setq caret t) + (setq first (1+ first))) + ((eq first ?-) + (setq hyphen t) + (setq first (1+ first))) + ((eq first ?\]) + (setq close-bracket t) + (setq first (1+ first)))) + (<= first last))) + (when (<= first last) + (setq chars + (cons first chars)) + (when (< first last) + (setq chars + (if (and (eq last (1+ first)) + (not (eq last ?-))) + (cons last chars) + (cons last (cons ?- chars)))))) + (setq range-list (cdr range-list))) + (setq chars + (mapcar (lambda (c) + (decode-char 'ucs c)) + chars)) + (when caret + (setq chars (cons ?^ chars))) + (when hyphen + (setq chars (cons ?- chars))) + (setq chars (cons ?\] chars)) + (setq chars (nreverse chars)) + (when close-bracket + (setq chars (cons ?\] chars))) + (when (equal chars '(?^ ?- ?\])) + (setq chars '(?- ?^ ?\]))) + (setq chars (cons ?\[ chars)) + (apply 'string chars))) + +;;; Parsing + +(defvar xsdre-current-regexp nil + "List of characters remaining to be parsed. Dynamically bound.") + +(defun xsdre-to-symbolic (str) + "Convert a W3C XML Schema datatypes regexp to a symbolic form. + +The symbolic form has the following structure: + +REGEXP ::= + (sequence REGEXP ...) + | (choice REGEXP ...) + | (repeat REGEXP MIN MAX) + | CHAR-CLASS + +CHAR-CLASS ::= + CHAR + | SYMBOLIC-CHAR-CLASS + | RANGE + | (union CHAR-CLASS ...) + | (difference CHAR-CLASS CHAR-CLASS) + +RANGE ::= (range LOWER UPPER) + +MIN ::= INTEGER +MAX ::= INTEGER | nil +CHAR ::= UNICODE +LOWER ::= UNICODE +UPPER ::= UNICODE +SYMBOLIC-CHAR-CLASS ::= SYMBOL + +where UNICODE is a integer specifying a Unicode code-point and +SYMBOLIC-CHAR-CLASS is a symbol which has either a `xsdre-char-class' +property whose value is a CHAR-CLASS, or a `xsdre-ranges' property +whose value is a range-list." + (let ((xsdre-current-regexp (string-to-list str))) + (condition-case err + (let ((symbolic (xsdre-parse-regexp))) + (if xsdre-current-regexp + (xsdre-parse-error "Unexpected %c" (car xsdre-current-regexp)) + symbolic)) + (xsdre-parse-error + (signal 'xsdre-invalid-regexp + (list (apply 'format (cdr err)) + (- (length str) + (length xsdre-current-regexp)))))))) + +(put 'xsdre-invalid-regexp + 'error-conditions + '(error xsdre-invalid-regexp)) + +(put 'xsdre-invalid-regexp + 'error-message + "Invalid W3C XML Schema Datatypes regular expression") + +(defun xsdre-parse-regexp () + (let ((branches nil)) + (while (progn + (setq branches (cons (xsdre-parse-branch) branches)) + (when (eq (car xsdre-current-regexp) ?|) + (xsdre-advance) + t))) + (if (null (cdr branches)) + (car branches) + (cons 'choice (nreverse branches))))) + +(defun xsdre-parse-branch () + (let (items) + (while (let ((item (xsdre-try-parse-atom))) + (when item + (let ((quantifier (xsdre-try-parse-quantifier))) + (when quantifier + (setq item + (list 'repeat + item + (car quantifier) + (cdr quantifier))))) + (setq items (cons item items))))) + (cond ((null items) '(sequence)) + ((null (cdr items)) (car items)) + (t (cons 'sequence (nreverse items)))))) + +(defun xsdre-try-parse-quantifier () + (let ((ch (car xsdre-current-regexp))) + (cond ((eq ch ?*) (xsdre-advance) '(0 . nil)) + ((eq ch ?+) (xsdre-advance) '(1 . nil)) + ((eq ch ??) (xsdre-advance) '(0 . 1)) + ((eq ch ?{) + (xsdre-advance) + (let ((lower (xsdre-parse-bound))) + (setq ch (car xsdre-current-regexp)) + (cond ((eq ch ?}) + (xsdre-advance) + (cons lower lower)) + ((eq ch ?,) + (xsdre-advance) + (cond ((eq (car xsdre-current-regexp) ?}) + (xsdre-advance) + (cons lower nil)) + (t + (let ((upper (xsdre-parse-bound))) + (xsdre-expect ?}) + (cons lower upper))))) + (t (xsdre-parse-error "Expected , or }"))))) + (t nil)))) + +(defun xsdre-parse-bound () + (let ((n 0)) + (while (progn + (let* ((ch (car xsdre-current-regexp)) + (digit (memq ch '(?9 ?8 ?7 ?6 ?5 ?4 ?3 ?2 ?1 ?0)))) + (unless digit + (xsdre-parse-error "Expected a digit")) + (setq n (+ (* n 10) + (length (cdr digit))))) + (xsdre-advance) + (not (memq (car xsdre-current-regexp) '(?} ?,))))) + n)) + + +(defun xsdre-try-parse-atom () + (let ((ch (car xsdre-current-regexp))) + (cond ((memq ch '(nil ?? ?* ?+ ?\) ?\{ ?\} ?| ?\])) nil) + ((eq ch ?\\) + (xsdre-advance) + (xsdre-parse-escape)) + ((eq ch ?\() + (xsdre-advance) + (let ((ret (xsdre-parse-regexp))) + (xsdre-expect ?\)) + ret)) + ((eq ch ?\[) + (xsdre-parse-char-class)) + ((eq ch ?.) + (xsdre-advance) + 'dot) + (t + (let ((uc (encode-char ch 'ucs))) + (unless uc + (xsdre-parse-error "%c is not a Unicode character" ch)) + (xsdre-advance) uc))))) + +(defun xsdre-parse-char-class () + (xsdre-advance) + (let (compl members ret) + (when (eq (car xsdre-current-regexp) ?^) + (setq compl t) + (xsdre-advance)) + (while (let ((member (xsdre-parse-char-class-member)) + uc1 uc2) + (cond ((eq (car xsdre-current-regexp) ?\-) + (xsdre-advance) + (cond ((eq (car xsdre-current-regexp) ?\[) + (setq members (cons member members)) + nil) + ((not (integerp member)) + (xsdre-parse-error "Lower bound is not a single character")) + ((not (setq uc1 + (encode-char member 'ucs))) + (xsdre-parse-error "Lower bound %c is not a Unicode character" + member)) + (t + (let ((upper (xsdre-parse-char-class-member))) + (unless (integerp upper) + (xsdre-parse-error "Upper bound is not a single character")) + (unless (setq uc2 + (encode-char upper 'ucs)) + (xsdre-parse-error "Upper bound %c is not a Unicode character" upper)) + (setq members + (cons (list 'range uc1 uc2) + members))) + (not (eq (car xsdre-current-regexp) ?\]))))) + (t (setq members (cons member members)) + (not (eq (car xsdre-current-regexp) ?\])))))) + (setq members (nreverse members)) + (if (null (cdr members)) + (setq ret (car members)) + (setq ret (cons 'union members))) + (when compl + (setq ret (list 'difference 'any ret))) + (when (eq (car xsdre-current-regexp) ?\[) + (setq ret + (list 'difference ret (xsdre-parse-char-class)))) + (xsdre-expect ?\]) + ret)) + +(defun xsdre-parse-char-class-member () + (let ((ch (car xsdre-current-regexp))) + (cond ((null ch) + (xsdre-parse-error "Expected ]")) + ((eq ch ?\\) + (xsdre-advance) + (xsdre-parse-escape)) + ((memq ch '(?\[ ?\] ?-)) + (xsdre-parse-error "%c must be quoted in a character class" ch)) + (t (xsdre-advance) ch)))) + +(defconst xsdre-single-escape + '((?s . space) + (?i . name-initial) + (?c . name-continue) + (?d . digit) + (?w . word))) + +(defun xsdre-parse-escape () + (let ((ch (car xsdre-current-regexp))) + (xsdre-advance) + (cond ((memq ch '(?\\ ?| ?. ?- ?^ ?* ?+ ?( ?) ?{ ?} ?[ ?])) ch) + ((eq ch ?r) ?\r) + ((eq ch ?n) ?\n) + ((eq ch ?t) ?\t) + ((cdr (assq ch xsdre-single-escape))) + ((let ((positive + (cdr (assq (downcase ch) xsdre-single-escape)))) + (and positive + (list 'difference 'any positive)))) + ((eq ch ?p) (xsdre-parse-prop)) + ((eq ch ?P) (list 'difference 'any (xsdre-parse-prop))) + (t (if ch + (xsdre-parse-error "Missing char after \\") + (xsdre-parse-error "Bad escape %c" ch)))))) + +(defun xsdre-parse-prop () + (xsdre-expect ?{) + (let ((name nil)) + (while (not (eq (car xsdre-current-regexp) ?\})) + (unless xsdre-current-regexp + (xsdre-parse-error "Expected ?")) + (setq name (cons (car xsdre-current-regexp) + name)) + (xsdre-advance)) + (xsdre-advance) + (setq name (nreverse name)) + (cond ((null name) (xsdre-parse-error "Empty property name")) + ((null (cdr name)) + (let ((category (intern (string (car name))))) + (unless (get category 'xsdre-unicode-category) + (xsdre-parse-error "%s is not a category" category)) + category)) + ((null (cddr name)) + (let ((category (intern (string (car name) (cadr name))))) + (unless (get category 'xsdre-unicode-category) + (xsdre-parse-error "%s is not a category" category)) + category)) + ((not (and (eq (car name) ?I) + (eq (cadr name) ?s))) + (xsdre-parse-error "Block name does not start with Is")) + (t + (let ((block (intern (apply 'string (cddr name))))) + (unless (get block 'xsdre-unicode-block) + (xsdre-parse-error "%s is not a block name" block)) + block))))) + +(defun xsdre-expect (ch) + (if (eq (car xsdre-current-regexp) ch) + (xsdre-advance) + (xsdre-parse-error "Expected %c" ch))) + +(defun xsdre-advance () + (setq xsdre-current-regexp + (cdr xsdre-current-regexp))) + +(defun xsdre-parse-error (&rest args) + (signal 'xsdre-parse-error args)) + +;; This error condition is used only internally. + +(put 'xsdre-parse-error + 'error-conditions + '(error xsdre-parse-error)) + +(put 'xsdre-parse-error + 'error-message + "Internal error in parsing XSD regexp") + +;;; Character class data + +(put 'dot 'xsdre-char-class '(difference any (union #xA #xD))) +(put 'digit 'xsdre-char-class 'Nd) +(put 'word 'xsdre-char-class '(difference any (union P Z C))) +(put 'space 'xsdre-char-class '(union #x9 #xA #xD #x20)) +(put 'any 'xsdre-ranges '((#x0 . #x10FFFF))) + +(defconst xsdre-gen-categories + '(Lu Ll Lt Lm Lo Mn Mc Me Nd Nl No Pc Pd + Ps Pe Pi Pf Po Zs Zl Zp Sm Sc Sk So Cc Cf Co)) + +(defun xsdre-gen-categories (file) + "Use a UnicodeData file to generate code to initialize Unicode categories. +Code is inserted into the current buffer." + (interactive "fUnicodeData file: ") + (save-excursion + (set-buffer (find-file-noselect file)) + (goto-char (point-min)) + (mapc (lambda (x) (put x 'xsdre-ranges nil)) xsdre-gen-categories) + (while (re-search-forward "^\\([0-9A-Fa-f]*\\);[^;]*;\\([A-Z][a-z]\\);" + nil + t) + (let* ((sym (intern (match-string-no-properties 2))) + (code (string-to-number (match-string-no-properties 1) + 16)) + (ranges (get sym 'xsdre-ranges)) + (last-range (car ranges)) + (forced-range (string= (buffer-substring-no-properties + (- (match-beginning 2) 6) + (1- (match-beginning 2))) + "Last>"))) + (cond ((and (integerp last-range) + (or forced-range + (eq code (1+ last-range)))) + (put sym + 'xsdre-ranges + (cons (cons last-range code) + (cdr ranges)))) + ((and (consp last-range) + (or forced-range + (eq code (1+ (cdr last-range))))) + (put sym + 'xsdre-ranges + (cons (cons (car last-range) code) + (cdr ranges)))) + (t + (put sym 'xsdre-ranges (cons code ranges)))))) + (mapc (lambda (x) + (put x + 'xsdre-ranges + (nreverse (get x 'xsdre-ranges))) + nil) + xsdre-gen-categories)) + (mapc (lambda (x) + (let ((start (point))) + (pp (list 'xsdre-def-primitive-category + (list 'quote x) + (list 'quote (get x 'xsdre-ranges))) + (current-buffer)) + (save-excursion + (goto-char start) + (down-list 2) + (while (condition-case err + (progn + (forward-sexp) + t) + (error nil)) + (when (and (< 70 (current-column)) + (not (looking-at ")"))) + (insert "\n") + (lisp-indent-line)))))) + xsdre-gen-categories)) + +(defun xsdre-def-primitive-category (sym ranges) + (put sym 'xsdre-ranges ranges) + (put sym 'xsdre-unicode-category t)) + +;;; Blocks + +(defun xsdre-def-block (sym ranges) + (put sym 'xsdre-ranges ranges) + (put sym 'xsdre-unicode-block t)) + +(xsdre-def-block 'BasicLatin '((#x0000 . #x007F))) +(xsdre-def-block 'Latin-1Supplement '((#x0080 . #x00FF))) +(xsdre-def-block 'LatinExtended-A '((#x0100 . #x017F))) +(xsdre-def-block 'LatinExtended-B '((#x0180 . #x024F))) +(xsdre-def-block 'IPAExtensions '((#x0250 . #x02AF))) +(xsdre-def-block 'SpacingModifierLetters '((#x02B0 . #x02FF))) +(xsdre-def-block 'CombiningDiacriticalMarks '((#x0300 . #x036F))) +(xsdre-def-block 'Greek '((#x0370 . #x03FF))) +(xsdre-def-block 'Cyrillic '((#x0400 . #x04FF))) +(xsdre-def-block 'Armenian '((#x0530 . #x058F))) +(xsdre-def-block 'Hebrew '((#x0590 . #x05FF))) +(xsdre-def-block 'Arabic '((#x0600 . #x06FF))) +(xsdre-def-block 'Syriac '((#x0700 . #x074F))) +(xsdre-def-block 'Thaana '((#x0780 . #x07BF))) +(xsdre-def-block 'Devanagari '((#x0900 . #x097F))) +(xsdre-def-block 'Bengali '((#x0980 . #x09FF))) +(xsdre-def-block 'Gurmukhi '((#x0A00 . #x0A7F))) +(xsdre-def-block 'Gujarati '((#x0A80 . #x0AFF))) +(xsdre-def-block 'Oriya '((#x0B00 . #x0B7F))) +(xsdre-def-block 'Tamil '((#x0B80 . #x0BFF))) +(xsdre-def-block 'Telugu '((#x0C00 . #x0C7F))) +(xsdre-def-block 'Kannada '((#x0C80 . #x0CFF))) +(xsdre-def-block 'Malayalam '((#x0D00 . #x0D7F))) +(xsdre-def-block 'Sinhala '((#x0D80 . #x0DFF))) +(xsdre-def-block 'Thai '((#x0E00 . #x0E7F))) +(xsdre-def-block 'Lao '((#x0E80 . #x0EFF))) +(xsdre-def-block 'Tibetan '((#x0F00 . #x0FFF))) +(xsdre-def-block 'Myanmar '((#x1000 . #x109F))) +(xsdre-def-block 'Georgian '((#x10A0 . #x10FF))) +(xsdre-def-block 'HangulJamo '((#x1100 . #x11FF))) +(xsdre-def-block 'Ethiopic '((#x1200 . #x137F))) +(xsdre-def-block 'Cherokee '((#x13A0 . #x13FF))) +(xsdre-def-block 'UnifiedCanadianAboriginalSyllabics '((#x1400 . #x167F))) +(xsdre-def-block 'Ogham '((#x1680 . #x169F))) +(xsdre-def-block 'Runic '((#x16A0 . #x16FF))) +(xsdre-def-block 'Khmer '((#x1780 . #x17FF))) +(xsdre-def-block 'Mongolian '((#x1800 . #x18AF))) +(xsdre-def-block 'LatinExtendedAdditional '((#x1E00 . #x1EFF))) +(xsdre-def-block 'GreekExtended '((#x1F00 . #x1FFF))) +(xsdre-def-block 'GeneralPunctuation '((#x2000 . #x206F))) +(xsdre-def-block 'SuperscriptsandSubscripts '((#x2070 . #x209F))) +(xsdre-def-block 'CurrencySymbols '((#x20A0 . #x20CF))) +(xsdre-def-block 'CombiningMarksforSymbols '((#x20D0 . #x20FF))) +(xsdre-def-block 'LetterlikeSymbols '((#x2100 . #x214F))) +(xsdre-def-block 'NumberForms '((#x2150 . #x218F))) +(xsdre-def-block 'Arrows '((#x2190 . #x21FF))) +(xsdre-def-block 'MathematicalOperators '((#x2200 . #x22FF))) +(xsdre-def-block 'MiscellaneousTechnical '((#x2300 . #x23FF))) +(xsdre-def-block 'ControlPictures '((#x2400 . #x243F))) +(xsdre-def-block 'OpticalCharacterRecognition '((#x2440 . #x245F))) +(xsdre-def-block 'EnclosedAlphanumerics '((#x2460 . #x24FF))) +(xsdre-def-block 'BoxDrawing '((#x2500 . #x257F))) +(xsdre-def-block 'BlockElements '((#x2580 . #x259F))) +(xsdre-def-block 'GeometricShapes '((#x25A0 . #x25FF))) +(xsdre-def-block 'MiscellaneousSymbols '((#x2600 . #x26FF))) +(xsdre-def-block 'Dingbats '((#x2700 . #x27BF))) +(xsdre-def-block 'BraillePatterns '((#x2800 . #x28FF))) +(xsdre-def-block 'CJKRadicalsSupplement '((#x2E80 . #x2EFF))) +(xsdre-def-block 'KangxiRadicals '((#x2F00 . #x2FDF))) +(xsdre-def-block 'IdeographicDescriptionCharacters '((#x2FF0 . #x2FFF))) +(xsdre-def-block 'CJKSymbolsandPunctuation '((#x3000 . #x303F))) +(xsdre-def-block 'Hiragana '((#x3040 . #x309F))) +(xsdre-def-block 'Katakana '((#x30A0 . #x30FF))) +(xsdre-def-block 'Bopomofo '((#x3100 . #x312F))) +(xsdre-def-block 'HangulCompatibilityJamo '((#x3130 . #x318F))) +(xsdre-def-block 'Kanbun '((#x3190 . #x319F))) +(xsdre-def-block 'BopomofoExtended '((#x31A0 . #x31BF))) +(xsdre-def-block 'EnclosedCJKLettersandMonths '((#x3200 . #x32FF))) +(xsdre-def-block 'CJKCompatibility '((#x3300 . #x33FF))) +(xsdre-def-block 'CJKUnifiedIdeographsExtensionA '((#x3400 . #x4DB5))) +(xsdre-def-block 'CJKUnifiedIdeographs '((#x4E00 . #x9FFF))) +(xsdre-def-block 'YiSyllables '((#xA000 . #xA48F))) +(xsdre-def-block 'YiRadicals '((#xA490 . #xA4CF))) +(xsdre-def-block 'HangulSyllables '((#xAC00 . #xD7A3))) +;;(xsdre-def-block 'HighSurrogates '((#xD800 . #xDB7F))) +;;(xsdre-def-block 'HighPrivateUseSurrogates '((#xDB80 . #xDBFF))) +;;(xsdre-def-block 'LowSurrogates '((#xDC00 . #xDFFF))) +(xsdre-def-block 'CJKCompatibilityIdeographs '((#xF900 . #xFAFF))) +(xsdre-def-block 'AlphabeticPresentationForms '((#xFB00 . #xFB4F))) +(xsdre-def-block 'ArabicPresentationForms-A '((#xFB50 . #xFDFF))) +(xsdre-def-block 'CombiningHalfMarks '((#xFE20 . #xFE2F))) +(xsdre-def-block 'CJKCompatibilityForms '((#xFE30 . #xFE4F))) +(xsdre-def-block 'SmallFormVariants '((#xFE50 . #xFE6F))) +(xsdre-def-block 'ArabicPresentationForms-B '((#xFE70 . #xFEFE))) +(xsdre-def-block 'Specials '((#xFEFF . #xFEFF))) +(xsdre-def-block 'HalfwidthandFullwidthForms '((#xFF00 . #xFFEF))) +(xsdre-def-block 'Specials '((#xFFF0 . #xFFFD))) +(xsdre-def-block 'OldItalic '((#x10300 . #x1032F))) +(xsdre-def-block 'Gothic '((#x10330 . #x1034F))) +(xsdre-def-block 'Deseret '((#x10400 . #x1044F))) +(xsdre-def-block 'ByzantineMusicalSymbols '((#x1D000 . #x1D0FF))) +(xsdre-def-block 'MusicalSymbols '((#x1D100 . #x1D1FF))) +(xsdre-def-block 'MathematicalAlphanumericSymbols '((#x1D400 . #x1D7FF))) +(xsdre-def-block 'CJKUnifiedIdeographsExtensionB '((#x20000 . #x2A6D6))) +(xsdre-def-block 'CJKCompatibilityIdeographsSupplement '((#x2F800 . #x2FA1F))) +(xsdre-def-block 'Tags '((#xE0000 . #xE007F))) +(xsdre-def-block 'PrivateUse '((#xE000 . #xF8FF) + (#xF0000 . #xFFFFD) + (#x100000 . #x10FFFD))) + +;;; Categories + +;;; Derived categories + +(defun xsdre-def-derived-category (sym char-class) + (put sym 'xsdre-char-class char-class) + (put sym 'xsdre-unicode-category t)) + +(xsdre-def-derived-category 'L '(union Lu Ll Lt Lm Lo)) +(xsdre-def-derived-category 'M '(union Mn Mc Me)) +(xsdre-def-derived-category 'N '(union Nd Nl No)) +(xsdre-def-derived-category 'P '(union Pc Pd Ps Pe Pi Pf Po)) +(xsdre-def-derived-category 'Z '(union Zs Zl Zp)) +(xsdre-def-derived-category 'S '(union Sm Sc Sk So)) +(xsdre-def-derived-category 'C '(union Cc Cf Co Cn)) +(xsdre-def-derived-category 'Cn '(difference any + (union L M N P Z S Cc Cf Co))) + +(xsdre-def-primitive-category + 'name-initial + '(#x003a + (#x0041 . #x005a) + #x005f + (#x0061 . #x007a) + (#x00c0 . #x00d6) + (#x00d8 . #x00f6) + (#x00f8 . #x0131) + (#x0134 . #x013e) + (#x0141 . #x0148) + (#x014a . #x017e) + (#x0180 . #x01c3) + (#x01cd . #x01f0) + (#x01f4 . #x01f5) + (#x01fa . #x0217) + (#x0250 . #x02a8) + (#x02bb . #x02c1) + #x0386 + (#x0388 . #x038a) + #x038c + (#x038e . #x03a1) + (#x03a3 . #x03ce) + (#x03d0 . #x03d6) + #x03da + #x03dc + #x03de + #x03e0 + (#x03e2 . #x03f3) + (#x0401 . #x040c) + (#x040e . #x044f) + (#x0451 . #x045c) + (#x045e . #x0481) + (#x0490 . #x04c4) + (#x04c7 . #x04c8) + (#x04cb . #x04cc) + (#x04d0 . #x04eb) + (#x04ee . #x04f5) + (#x04f8 . #x04f9) + (#x0531 . #x0556) + #x0559 + (#x0561 . #x0586) + (#x05d0 . #x05ea) + (#x05f0 . #x05f2) + (#x0621 . #x063a) + (#x0641 . #x064a) + (#x0671 . #x06b7) + (#x06ba . #x06be) + (#x06c0 . #x06ce) + (#x06d0 . #x06d3) + #x06d5 + (#x06e5 . #x06e6) + (#x0905 . #x0939) + #x093d + (#x0958 . #x0961) + (#x0985 . #x098c) + (#x098f . #x0990) + (#x0993 . #x09a8) + (#x09aa . #x09b0) + #x09b2 + (#x09b6 . #x09b9) + (#x09dc . #x09dd) + (#x09df . #x09e1) + (#x09f0 . #x09f1) + (#x0a05 . #x0a0a) + (#x0a0f . #x0a10) + (#x0a13 . #x0a28) + (#x0a2a . #x0a30) + (#x0a32 . #x0a33) + (#x0a35 . #x0a36) + (#x0a38 . #x0a39) + (#x0a59 . #x0a5c) + #x0a5e + (#x0a72 . #x0a74) + (#x0a85 . #x0a8b) + #x0a8d + (#x0a8f . #x0a91) + (#x0a93 . #x0aa8) + (#x0aaa . #x0ab0) + (#x0ab2 . #x0ab3) + (#x0ab5 . #x0ab9) + #x0abd + #x0ae0 + (#x0b05 . #x0b0c) + (#x0b0f . #x0b10) + (#x0b13 . #x0b28) + (#x0b2a . #x0b30) + (#x0b32 . #x0b33) + (#x0b36 . #x0b39) + #x0b3d + (#x0b5c . #x0b5d) + (#x0b5f . #x0b61) + (#x0b85 . #x0b8a) + (#x0b8e . #x0b90) + (#x0b92 . #x0b95) + (#x0b99 . #x0b9a) + #x0b9c + (#x0b9e . #x0b9f) + (#x0ba3 . #x0ba4) + (#x0ba8 . #x0baa) + (#x0bae . #x0bb5) + (#x0bb7 . #x0bb9) + (#x0c05 . #x0c0c) + (#x0c0e . #x0c10) + (#x0c12 . #x0c28) + (#x0c2a . #x0c33) + (#x0c35 . #x0c39) + (#x0c60 . #x0c61) + (#x0c85 . #x0c8c) + (#x0c8e . #x0c90) + (#x0c92 . #x0ca8) + (#x0caa . #x0cb3) + (#x0cb5 . #x0cb9) + #x0cde + (#x0ce0 . #x0ce1) + (#x0d05 . #x0d0c) + (#x0d0e . #x0d10) + (#x0d12 . #x0d28) + (#x0d2a . #x0d39) + (#x0d60 . #x0d61) + (#x0e01 . #x0e2e) + #x0e30 + (#x0e32 . #x0e33) + (#x0e40 . #x0e45) + (#x0e81 . #x0e82) + #x0e84 + (#x0e87 . #x0e88) + #x0e8a + #x0e8d + (#x0e94 . #x0e97) + (#x0e99 . #x0e9f) + (#x0ea1 . #x0ea3) + #x0ea5 + #x0ea7 + (#x0eaa . #x0eab) + (#x0ead . #x0eae) + #x0eb0 + (#x0eb2 . #x0eb3) + #x0ebd + (#x0ec0 . #x0ec4) + (#x0f40 . #x0f47) + (#x0f49 . #x0f69) + (#x10a0 . #x10c5) + (#x10d0 . #x10f6) + #x1100 + (#x1102 . #x1103) + (#x1105 . #x1107) + #x1109 + (#x110b . #x110c) + (#x110e . #x1112) + #x113c + #x113e + #x1140 + #x114c + #x114e + #x1150 + (#x1154 . #x1155) + #x1159 + (#x115f . #x1161) + #x1163 + #x1165 + #x1167 + #x1169 + (#x116d . #x116e) + (#x1172 . #x1173) + #x1175 + #x119e + #x11a8 + #x11ab + (#x11ae . #x11af) + (#x11b7 . #x11b8) + #x11ba + (#x11bc . #x11c2) + #x11eb + #x11f0 + #x11f9 + (#x1e00 . #x1e9b) + (#x1ea0 . #x1ef9) + (#x1f00 . #x1f15) + (#x1f18 . #x1f1d) + (#x1f20 . #x1f45) + (#x1f48 . #x1f4d) + (#x1f50 . #x1f57) + #x1f59 + #x1f5b + #x1f5d + (#x1f5f . #x1f7d) + (#x1f80 . #x1fb4) + (#x1fb6 . #x1fbc) + #x1fbe + (#x1fc2 . #x1fc4) + (#x1fc6 . #x1fcc) + (#x1fd0 . #x1fd3) + (#x1fd6 . #x1fdb) + (#x1fe0 . #x1fec) + (#x1ff2 . #x1ff4) + (#x1ff6 . #x1ffc) + #x2126 + (#x212a . #x212b) + #x212e + (#x2180 . #x2182) + #x3007 + (#x3021 . #x3029) + (#x3041 . #x3094) + (#x30a1 . #x30fa) + (#x3105 . #x312c) + (#x4e00 . #x9fa5) + (#xac00 . #xd7a3))) + +(xsdre-def-derived-category 'name-continue '(union name-initial + name-continue-not-initial)) + +(xsdre-def-primitive-category + 'name-continue-not-initial + '((#x002d . #x002e) + (#x0030 . #x0039) + #x00b7 + (#x02d0 . #x02d1) + (#x0300 . #x0345) + (#x0360 . #x0361) + #x0387 + (#x0483 . #x0486) + (#x0591 . #x05a1) + (#x05a3 . #x05b9) + (#x05bb . #x05bd) + #x05bf + (#x05c1 . #x05c2) + #x05c4 + #x0640 + (#x064b . #x0652) + (#x0660 . #x0669) + #x0670 + (#x06d6 . #x06dc) + (#x06dd . #x06df) + (#x06e0 . #x06e4) + (#x06e7 . #x06e8) + (#x06ea . #x06ed) + (#x06f0 . #x06f9) + (#x0901 . #x0903) + #x093c + (#x093e . #x094c) + #x094d + (#x0951 . #x0954) + (#x0962 . #x0963) + (#x0966 . #x096f) + (#x0981 . #x0983) + #x09bc + (#x09be . #x09bf) + (#x09c0 . #x09c4) + (#x09c7 . #x09c8) + (#x09cb . #x09cd) + #x09d7 + (#x09e2 . #x09e3) + (#x09e6 . #x09ef) + #x0a02 + #x0a3c + (#x0a3e . #x0a42) + (#x0a47 . #x0a48) + (#x0a4b . #x0a4d) + (#x0a66 . #x0a6f) + (#x0a70 . #x0a71) + (#x0a81 . #x0a83) + #x0abc + (#x0abe . #x0ac5) + (#x0ac7 . #x0ac9) + (#x0acb . #x0acd) + (#x0ae6 . #x0aef) + (#x0b01 . #x0b03) + #x0b3c + (#x0b3e . #x0b43) + (#x0b47 . #x0b48) + (#x0b4b . #x0b4d) + (#x0b56 . #x0b57) + (#x0b66 . #x0b6f) + (#x0b82 . #x0b83) + (#x0bbe . #x0bc2) + (#x0bc6 . #x0bc8) + (#x0bca . #x0bcd) + #x0bd7 + (#x0be7 . #x0bef) + (#x0c01 . #x0c03) + (#x0c3e . #x0c44) + (#x0c46 . #x0c48) + (#x0c4a . #x0c4d) + (#x0c55 . #x0c56) + (#x0c66 . #x0c6f) + (#x0c82 . #x0c83) + (#x0cbe . #x0cc4) + (#x0cc6 . #x0cc8) + (#x0cca . #x0ccd) + (#x0cd5 . #x0cd6) + (#x0ce6 . #x0cef) + (#x0d02 . #x0d03) + (#x0d3e . #x0d43) + (#x0d46 . #x0d48) + (#x0d4a . #x0d4d) + #x0d57 + (#x0d66 . #x0d6f) + #x0e31 + (#x0e34 . #x0e3a) + (#x0e46 . #x0e4e) + (#x0e50 . #x0e59) + #x0eb1 + (#x0eb4 . #x0eb9) + (#x0ebb . #x0ebc) + #x0ec6 + (#x0ec8 . #x0ecd) + (#x0ed0 . #x0ed9) + (#x0f18 . #x0f19) + (#x0f20 . #x0f29) + #x0f35 + #x0f37 + #x0f39 + (#x0f3e . #x0f3f) + (#x0f71 . #x0f84) + (#x0f86 . #x0f8b) + (#x0f90 . #x0f95) + #x0f97 + (#x0f99 . #x0fad) + (#x0fb1 . #x0fb7) + #x0fb9 + (#x20d0 . #x20dc) + #x20e1 + #x3005 + (#x302a . #x302f) + (#x3031 . #x3035) + #x3099 + #x309a + (#x309d . #x309e) + (#x30fc . #x30fe))) + +;;; Auto-generated section. + +;; The rest of the file was auto-generated by doing M-x xsdre-gen-categories +;; on UnicodeData-3.1.0.txt available from +;; http://www.unicode.org/Public/3.1-Update/UnicodeData-3.1.0.txt + +(xsdre-def-primitive-category 'Lu + '((65 . 90) + (192 . 214) + (216 . 222) + 256 258 260 262 264 266 268 270 272 274 276 + 278 280 282 284 286 288 290 292 294 296 298 + 300 302 304 306 308 310 313 315 317 319 321 + 323 325 327 330 332 334 336 338 340 342 344 + 346 348 350 352 354 356 358 360 362 364 366 + 368 370 372 374 + (376 . 377) + 379 381 + (385 . 386) + 388 + (390 . 391) + (393 . 395) + (398 . 401) + (403 . 404) + (406 . 408) + (412 . 413) + (415 . 416) + 418 420 + (422 . 423) + 425 428 + (430 . 431) + (433 . 435) + 437 + (439 . 440) + 444 452 455 458 461 463 465 467 469 471 473 + 475 478 480 482 484 486 488 490 492 494 497 + 500 + (502 . 504) + 506 508 510 512 514 516 518 520 522 524 526 + 528 530 532 534 536 538 540 542 546 548 550 + 552 554 556 558 560 562 902 + (904 . 906) + 908 + (910 . 911) + (913 . 929) + (931 . 939) + (978 . 980) + 986 988 990 992 994 996 998 1000 1002 1004 + 1006 1012 + (1024 . 1071) + 1120 1122 1124 1126 1128 1130 1132 1134 1136 + 1138 1140 1142 1144 1146 1148 1150 1152 1164 + 1166 1168 1170 1172 1174 1176 1178 1180 1182 + 1184 1186 1188 1190 1192 1194 1196 1198 1200 + 1202 1204 1206 1208 1210 1212 1214 + (1216 . 1217) + 1219 1223 1227 1232 1234 1236 1238 1240 1242 + 1244 1246 1248 1250 1252 1254 1256 1258 1260 + 1262 1264 1266 1268 1272 + (1329 . 1366) + (4256 . 4293) + 7680 7682 7684 7686 7688 7690 7692 7694 7696 + 7698 7700 7702 7704 7706 7708 7710 7712 7714 + 7716 7718 7720 7722 7724 7726 7728 7730 7732 + 7734 7736 7738 7740 7742 7744 7746 7748 7750 + 7752 7754 7756 7758 7760 7762 7764 7766 7768 + 7770 7772 7774 7776 7778 7780 7782 7784 7786 + 7788 7790 7792 7794 7796 7798 7800 7802 7804 + 7806 7808 7810 7812 7814 7816 7818 7820 7822 + 7824 7826 7828 7840 7842 7844 7846 7848 7850 + 7852 7854 7856 7858 7860 7862 7864 7866 7868 + 7870 7872 7874 7876 7878 7880 7882 7884 7886 + 7888 7890 7892 7894 7896 7898 7900 7902 7904 + 7906 7908 7910 7912 7914 7916 7918 7920 7922 + 7924 7926 7928 + (7944 . 7951) + (7960 . 7965) + (7976 . 7983) + (7992 . 7999) + (8008 . 8013) + 8025 8027 8029 8031 + (8040 . 8047) + (8120 . 8123) + (8136 . 8139) + (8152 . 8155) + (8168 . 8172) + (8184 . 8187) + 8450 8455 + (8459 . 8461) + (8464 . 8466) + 8469 + (8473 . 8477) + 8484 8486 8488 + (8490 . 8493) + (8496 . 8497) + 8499 + (65313 . 65338) + (66560 . 66597) + (119808 . 119833) + (119860 . 119885) + (119912 . 119937) + 119964 + (119966 . 119967) + 119970 + (119973 . 119974) + (119977 . 119980) + (119982 . 119989) + (120016 . 120041) + (120068 . 120069) + (120071 . 120074) + (120077 . 120084) + (120086 . 120092) + (120120 . 120121) + (120123 . 120126) + (120128 . 120132) + 120134 + (120138 . 120144) + (120172 . 120197) + (120224 . 120249) + (120276 . 120301) + (120328 . 120353) + (120380 . 120405) + (120432 . 120457) + (120488 . 120512) + (120546 . 120570) + (120604 . 120628) + (120662 . 120686) + (120720 . 120744))) +(xsdre-def-primitive-category 'Ll + '((97 . 122) + 170 181 186 + (223 . 246) + (248 . 255) + 257 259 261 263 265 267 269 271 273 275 277 + 279 281 283 285 287 289 291 293 295 297 299 + 301 303 305 307 309 + (311 . 312) + 314 316 318 320 322 324 326 + (328 . 329) + 331 333 335 337 339 341 343 345 347 349 351 + 353 355 357 359 361 363 365 367 369 371 373 + 375 378 380 + (382 . 384) + 387 389 392 + (396 . 397) + 402 405 + (409 . 411) + 414 417 419 421 424 + (426 . 427) + 429 432 436 438 + (441 . 442) + (445 . 447) + 454 457 460 462 464 466 468 470 472 474 + (476 . 477) + 479 481 483 485 487 489 491 493 + (495 . 496) + 499 501 505 507 509 511 513 515 517 519 521 + 523 525 527 529 531 533 535 537 539 541 543 + 547 549 551 553 555 557 559 561 563 + (592 . 685) + 912 + (940 . 974) + (976 . 977) + (981 . 983) + 987 989 991 993 995 997 999 1001 1003 1005 + + (1007 . 1011) + 1013 + (1072 . 1119) + 1121 1123 1125 1127 1129 1131 1133 1135 1137 + 1139 1141 1143 1145 1147 1149 1151 1153 1165 + 1167 1169 1171 1173 1175 1177 1179 1181 1183 + 1185 1187 1189 1191 1193 1195 1197 1199 1201 + 1203 1205 1207 1209 1211 1213 1215 1218 1220 + 1224 1228 1233 1235 1237 1239 1241 1243 1245 + 1247 1249 1251 1253 1255 1257 1259 1261 1263 + 1265 1267 1269 1273 + (1377 . 1415) + 7681 7683 7685 7687 7689 7691 7693 7695 7697 + 7699 7701 7703 7705 7707 7709 7711 7713 7715 + 7717 7719 7721 7723 7725 7727 7729 7731 7733 + 7735 7737 7739 7741 7743 7745 7747 7749 7751 + 7753 7755 7757 7759 7761 7763 7765 7767 7769 + 7771 7773 7775 7777 7779 7781 7783 7785 7787 + 7789 7791 7793 7795 7797 7799 7801 7803 7805 + 7807 7809 7811 7813 7815 7817 7819 7821 7823 + 7825 7827 + (7829 . 7835) + 7841 7843 7845 7847 7849 7851 7853 7855 7857 + 7859 7861 7863 7865 7867 7869 7871 7873 7875 + 7877 7879 7881 7883 7885 7887 7889 7891 7893 + 7895 7897 7899 7901 7903 7905 7907 7909 7911 + 7913 7915 7917 7919 7921 7923 7925 7927 7929 + + (7936 . 7943) + (7952 . 7957) + (7968 . 7975) + (7984 . 7991) + (8000 . 8005) + (8016 . 8023) + (8032 . 8039) + (8048 . 8061) + (8064 . 8071) + (8080 . 8087) + (8096 . 8103) + (8112 . 8116) + (8118 . 8119) + 8126 + (8130 . 8132) + (8134 . 8135) + (8144 . 8147) + (8150 . 8151) + (8160 . 8167) + (8178 . 8180) + (8182 . 8183) + 8319 8458 + (8462 . 8463) + 8467 8495 8500 8505 + (64256 . 64262) + (64275 . 64279) + (65345 . 65370) + (66600 . 66637) + (119834 . 119859) + (119886 . 119892) + (119894 . 119911) + (119938 . 119963) + (119990 . 119993) + 119995 + (119997 . 120000) + (120002 . 120003) + (120005 . 120015) + (120042 . 120067) + (120094 . 120119) + (120146 . 120171) + (120198 . 120223) + (120250 . 120275) + (120302 . 120327) + (120354 . 120379) + (120406 . 120431) + (120458 . 120483) + (120514 . 120538) + (120540 . 120545) + (120572 . 120596) + (120598 . 120603) + (120630 . 120654) + (120656 . 120661) + (120688 . 120712) + (120714 . 120719) + (120746 . 120770) + (120772 . 120777))) +(xsdre-def-primitive-category 'Lt + '(453 456 459 498 + (8072 . 8079) + (8088 . 8095) + (8104 . 8111) + 8124 8140 8188)) +(xsdre-def-primitive-category 'Lm + '((688 . 696) + (699 . 705) + (720 . 721) + (736 . 740) + 750 890 1369 1600 + (1765 . 1766) + 3654 3782 6211 12293 + (12337 . 12341) + (12445 . 12446) + (12540 . 12542) + 65392 + (65438 . 65439))) +(xsdre-def-primitive-category 'Lo + '(443 + (448 . 451) + (1488 . 1514) + (1520 . 1522) + (1569 . 1594) + (1601 . 1610) + (1649 . 1747) + 1749 + (1786 . 1788) + 1808 + (1810 . 1836) + (1920 . 1957) + (2309 . 2361) + 2365 2384 + (2392 . 2401) + (2437 . 2444) + (2447 . 2448) + (2451 . 2472) + (2474 . 2480) + 2482 + (2486 . 2489) + (2524 . 2525) + (2527 . 2529) + (2544 . 2545) + (2565 . 2570) + (2575 . 2576) + (2579 . 2600) + (2602 . 2608) + (2610 . 2611) + (2613 . 2614) + (2616 . 2617) + (2649 . 2652) + 2654 + (2674 . 2676) + (2693 . 2699) + 2701 + (2703 . 2705) + (2707 . 2728) + (2730 . 2736) + (2738 . 2739) + (2741 . 2745) + 2749 2768 2784 + (2821 . 2828) + (2831 . 2832) + (2835 . 2856) + (2858 . 2864) + (2866 . 2867) + (2870 . 2873) + 2877 + (2908 . 2909) + (2911 . 2913) + (2949 . 2954) + (2958 . 2960) + (2962 . 2965) + (2969 . 2970) + 2972 + (2974 . 2975) + (2979 . 2980) + (2984 . 2986) + (2990 . 2997) + (2999 . 3001) + (3077 . 3084) + (3086 . 3088) + (3090 . 3112) + (3114 . 3123) + (3125 . 3129) + (3168 . 3169) + (3205 . 3212) + (3214 . 3216) + (3218 . 3240) + (3242 . 3251) + (3253 . 3257) + 3294 + (3296 . 3297) + (3333 . 3340) + (3342 . 3344) + (3346 . 3368) + (3370 . 3385) + (3424 . 3425) + (3461 . 3478) + (3482 . 3505) + (3507 . 3515) + 3517 + (3520 . 3526) + (3585 . 3632) + (3634 . 3635) + (3648 . 3653) + (3713 . 3714) + 3716 + (3719 . 3720) + 3722 3725 + (3732 . 3735) + (3737 . 3743) + (3745 . 3747) + 3749 3751 + (3754 . 3755) + (3757 . 3760) + (3762 . 3763) + 3773 + (3776 . 3780) + (3804 . 3805) + 3840 + (3904 . 3911) + (3913 . 3946) + (3976 . 3979) + (4096 . 4129) + (4131 . 4135) + (4137 . 4138) + (4176 . 4181) + (4304 . 4342) + (4352 . 4441) + (4447 . 4514) + (4520 . 4601) + (4608 . 4614) + (4616 . 4678) + 4680 + (4682 . 4685) + (4688 . 4694) + 4696 + (4698 . 4701) + (4704 . 4742) + 4744 + (4746 . 4749) + (4752 . 4782) + 4784 + (4786 . 4789) + (4792 . 4798) + 4800 + (4802 . 4805) + (4808 . 4814) + (4816 . 4822) + (4824 . 4846) + (4848 . 4878) + 4880 + (4882 . 4885) + (4888 . 4894) + (4896 . 4934) + (4936 . 4954) + (5024 . 5108) + (5121 . 5740) + (5743 . 5750) + (5761 . 5786) + (5792 . 5866) + (6016 . 6067) + (6176 . 6210) + (6212 . 6263) + (6272 . 6312) + (8501 . 8504) + 12294 + (12353 . 12436) + (12449 . 12538) + (12549 . 12588) + (12593 . 12686) + (12704 . 12727) + (13312 . 19893) + (19968 . 40869) + (40960 . 42124) + (44032 . 55203) + (63744 . 64045) + 64285 + (64287 . 64296) + (64298 . 64310) + (64312 . 64316) + 64318 + (64320 . 64321) + (64323 . 64324) + (64326 . 64433) + (64467 . 64829) + (64848 . 64911) + (64914 . 64967) + (65008 . 65019) + (65136 . 65138) + 65140 + (65142 . 65276) + (65382 . 65391) + (65393 . 65437) + (65440 . 65470) + (65474 . 65479) + (65482 . 65487) + (65490 . 65495) + (65498 . 65500) + (66304 . 66334) + (66352 . 66377) + (131072 . 173782) + (194560 . 195101))) +(xsdre-def-primitive-category 'Mn + '((768 . 846) + (864 . 866) + (1155 . 1158) + (1425 . 1441) + (1443 . 1465) + (1467 . 1469) + 1471 + (1473 . 1474) + 1476 + (1611 . 1621) + 1648 + (1750 . 1756) + (1759 . 1764) + (1767 . 1768) + (1770 . 1773) + 1809 + (1840 . 1866) + (1958 . 1968) + (2305 . 2306) + 2364 + (2369 . 2376) + 2381 + (2385 . 2388) + (2402 . 2403) + 2433 2492 + (2497 . 2500) + 2509 + (2530 . 2531) + 2562 2620 + (2625 . 2626) + (2631 . 2632) + (2635 . 2637) + (2672 . 2673) + (2689 . 2690) + 2748 + (2753 . 2757) + (2759 . 2760) + 2765 2817 2876 2879 + (2881 . 2883) + 2893 2902 2946 3008 3021 + (3134 . 3136) + (3142 . 3144) + (3146 . 3149) + (3157 . 3158) + 3263 3270 + (3276 . 3277) + (3393 . 3395) + 3405 3530 + (3538 . 3540) + 3542 3633 + (3636 . 3642) + (3655 . 3662) + 3761 + (3764 . 3769) + (3771 . 3772) + (3784 . 3789) + (3864 . 3865) + 3893 3895 3897 + (3953 . 3966) + (3968 . 3972) + (3974 . 3975) + (3984 . 3991) + (3993 . 4028) + 4038 + (4141 . 4144) + 4146 + (4150 . 4151) + 4153 + (4184 . 4185) + (6071 . 6077) + 6086 + (6089 . 6099) + 6313 + (8400 . 8412) + 8417 + (12330 . 12335) + (12441 . 12442) + 64286 + (65056 . 65059) + (119143 . 119145) + (119163 . 119170) + (119173 . 119179) + (119210 . 119213))) +(xsdre-def-primitive-category 'Mc + '(2307 + (2366 . 2368) + (2377 . 2380) + (2434 . 2435) + (2494 . 2496) + (2503 . 2504) + (2507 . 2508) + 2519 + (2622 . 2624) + 2691 + (2750 . 2752) + 2761 + (2763 . 2764) + (2818 . 2819) + 2878 2880 + (2887 . 2888) + (2891 . 2892) + 2903 2947 + (3006 . 3007) + (3009 . 3010) + (3014 . 3016) + (3018 . 3020) + 3031 + (3073 . 3075) + (3137 . 3140) + (3202 . 3203) + 3262 + (3264 . 3268) + (3271 . 3272) + (3274 . 3275) + (3285 . 3286) + (3330 . 3331) + (3390 . 3392) + (3398 . 3400) + (3402 . 3404) + 3415 + (3458 . 3459) + (3535 . 3537) + (3544 . 3551) + (3570 . 3571) + (3902 . 3903) + 3967 4140 4145 4152 + (4182 . 4183) + (6068 . 6070) + (6078 . 6085) + (6087 . 6088) + (119141 . 119142) + (119149 . 119154))) +(xsdre-def-primitive-category 'Me + '((1160 . 1161) + (1757 . 1758) + (8413 . 8416) + (8418 . 8419))) +(xsdre-def-primitive-category 'Nd + '((48 . 57) + (1632 . 1641) + (1776 . 1785) + (2406 . 2415) + (2534 . 2543) + (2662 . 2671) + (2790 . 2799) + (2918 . 2927) + (3047 . 3055) + (3174 . 3183) + (3302 . 3311) + (3430 . 3439) + (3664 . 3673) + (3792 . 3801) + (3872 . 3881) + (4160 . 4169) + (4969 . 4977) + (6112 . 6121) + (6160 . 6169) + (65296 . 65305) + (120782 . 120831))) +(xsdre-def-primitive-category 'Nl + '((5870 . 5872) + (8544 . 8579) + 12295 + (12321 . 12329) + (12344 . 12346) + 66378)) +(xsdre-def-primitive-category 'No + '((178 . 179) + 185 + (188 . 190) + (2548 . 2553) + (3056 . 3058) + (3882 . 3891) + (4978 . 4988) + 8304 + (8308 . 8313) + (8320 . 8329) + (8531 . 8543) + (9312 . 9371) + 9450 + (10102 . 10131) + (12690 . 12693) + (12832 . 12841) + (12928 . 12937) + (66336 . 66339))) +(xsdre-def-primitive-category 'Pc + '(95 + (8255 . 8256) + 12539 + (65075 . 65076) + (65101 . 65103) + 65343 65381)) +(xsdre-def-primitive-category 'Pd + '(45 173 1418 6150 + (8208 . 8213) + 12316 12336 + (65073 . 65074) + 65112 65123 65293)) +(xsdre-def-primitive-category 'Ps + '(40 91 123 3898 3900 5787 8218 8222 8261 8317 + 8333 9001 12296 12298 12300 12302 12304 + 12308 12310 12312 12314 12317 64830 65077 + 65079 65081 65083 65085 65087 65089 65091 + 65113 65115 65117 65288 65339 65371 65378)) +(xsdre-def-primitive-category 'Pe + '(41 93 125 3899 3901 5788 8262 8318 8334 9002 + 12297 12299 12301 12303 12305 12309 12311 + 12313 12315 + (12318 . 12319) + 64831 65078 65080 65082 65084 65086 65088 + 65090 65092 65114 65116 65118 65289 65341 + 65373 65379)) +(xsdre-def-primitive-category 'Pi + '(171 8216 + (8219 . 8220) + 8223 8249)) +(xsdre-def-primitive-category 'Pf + '(187 8217 8221 8250)) +(xsdre-def-primitive-category 'Po + '((33 . 35) + (37 . 39) + 42 44 + (46 . 47) + (58 . 59) + (63 . 64) + 92 161 183 191 894 903 + (1370 . 1375) + 1417 1470 1472 1475 + (1523 . 1524) + 1548 1563 1567 + (1642 . 1645) + 1748 + (1792 . 1805) + (2404 . 2405) + 2416 3572 3663 + (3674 . 3675) + (3844 . 3858) + 3973 + (4170 . 4175) + 4347 + (4961 . 4968) + (5741 . 5742) + (5867 . 5869) + (6100 . 6106) + 6108 + (6144 . 6149) + (6151 . 6154) + (8214 . 8215) + (8224 . 8231) + (8240 . 8248) + (8251 . 8254) + (8257 . 8259) + (8264 . 8269) + (12289 . 12291) + 65072 + (65097 . 65100) + (65104 . 65106) + (65108 . 65111) + (65119 . 65121) + 65128 + (65130 . 65131) + (65281 . 65283) + (65285 . 65287) + 65290 65292 + (65294 . 65295) + (65306 . 65307) + (65311 . 65312) + 65340 65377 65380)) +(xsdre-def-primitive-category 'Zs + '(32 160 5760 + (8192 . 8203) + 8239 12288)) +(xsdre-def-primitive-category 'Zl + '(8232)) +(xsdre-def-primitive-category 'Zp + '(8233)) +(xsdre-def-primitive-category 'Sm + '(43 + (60 . 62) + 124 126 172 177 215 247 8260 + (8314 . 8316) + (8330 . 8332) + (8592 . 8596) + (8602 . 8603) + 8608 8611 8614 8622 + (8654 . 8655) + 8658 8660 + (8704 . 8945) + (8968 . 8971) + (8992 . 8993) + 9655 9665 9839 64297 65122 + (65124 . 65126) + 65291 + (65308 . 65310) + 65372 65374 65506 + (65513 . 65516) + 120513 120539 120571 120597 120629 120655 + 120687 120713 120745 120771)) +(xsdre-def-primitive-category 'Sc + '(36 + (162 . 165) + (2546 . 2547) + 3647 6107 + (8352 . 8367) + 65129 65284 + (65504 . 65505) + (65509 . 65510))) +(xsdre-def-primitive-category 'Sk + '(94 96 168 175 180 184 + (697 . 698) + (706 . 719) + (722 . 735) + (741 . 749) + (884 . 885) + (900 . 901) + 8125 + (8127 . 8129) + (8141 . 8143) + (8157 . 8159) + (8173 . 8175) + (8189 . 8190) + (12443 . 12444) + 65342 65344 65507)) +(xsdre-def-primitive-category 'So + '((166 . 167) + 169 174 176 182 1154 1769 + (1789 . 1790) + 2554 2928 + (3841 . 3843) + (3859 . 3863) + (3866 . 3871) + 3892 3894 3896 + (4030 . 4037) + (4039 . 4044) + 4047 + (8448 . 8449) + (8451 . 8454) + (8456 . 8457) + 8468 + (8470 . 8472) + (8478 . 8483) + 8485 8487 8489 8494 8498 8506 + (8597 . 8601) + (8604 . 8607) + (8609 . 8610) + (8612 . 8613) + (8615 . 8621) + (8623 . 8653) + (8656 . 8657) + 8659 + (8661 . 8691) + (8960 . 8967) + (8972 . 8991) + (8994 . 9000) + (9003 . 9083) + (9085 . 9114) + (9216 . 9254) + (9280 . 9290) + (9372 . 9449) + (9472 . 9621) + (9632 . 9654) + (9656 . 9664) + (9666 . 9719) + (9728 . 9747) + (9753 . 9838) + (9840 . 9841) + (9985 . 9988) + (9990 . 9993) + (9996 . 10023) + (10025 . 10059) + 10061 + (10063 . 10066) + 10070 + (10072 . 10078) + (10081 . 10087) + 10132 + (10136 . 10159) + (10161 . 10174) + (10240 . 10495) + (11904 . 11929) + (11931 . 12019) + (12032 . 12245) + (12272 . 12283) + 12292 + (12306 . 12307) + 12320 + (12342 . 12343) + (12350 . 12351) + (12688 . 12689) + (12694 . 12703) + (12800 . 12828) + (12842 . 12867) + (12896 . 12923) + 12927 + (12938 . 12976) + (12992 . 13003) + (13008 . 13054) + (13056 . 13174) + (13179 . 13277) + (13280 . 13310) + (42128 . 42145) + (42148 . 42163) + (42165 . 42176) + (42178 . 42180) + 42182 65508 65512 + (65517 . 65518) + (65532 . 65533) + (118784 . 119029) + (119040 . 119078) + (119082 . 119140) + (119146 . 119148) + (119171 . 119172) + (119180 . 119209) + (119214 . 119261))) +(xsdre-def-primitive-category 'Cc + '((0 . 31) + (127 . 159))) +(xsdre-def-primitive-category 'Cf + '(1807 + (6155 . 6158) + (8204 . 8207) + (8234 . 8238) + (8298 . 8303) + 65279 + (65529 . 65531) + (119155 . 119162) + 917505 + (917536 . 917631))) +(xsdre-def-primitive-category 'Co + '((57344 . 63743) + (983040 . 1048573) + (1048576 . 1114109))) + +(provide 'xsd-regexp) + +;; arch-tag: bf990d61-a26c-4fd3-b578-56a5640729da +;;; xsd-regexp.el ends here diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el index e2fb338242f..f34427c3140 100644 --- a/lisp/obsolete/fast-lock.el +++ b/lisp/obsolete/fast-lock.el @@ -183,6 +183,8 @@ (require 'font-lock) +(declare-function msdos-long-file-names "msdos.c") + ;; Make sure fast-lock.el is supported. (if (and (eq system-type 'ms-dos) (not (msdos-long-file-names))) (error "`fast-lock' was written for long file name systems")) diff --git a/lisp/obsolete/mlsupport.el b/lisp/obsolete/mlsupport.el index 2465ea4eabd..7e2663ed903 100644 --- a/lisp/obsolete/mlsupport.el +++ b/lisp/obsolete/mlsupport.el @@ -127,13 +127,6 @@ (defun ml-message (&rest args) (message "%s" (apply 'concat args))) -(defun kill-to-end-of-line () - (ml-prefix-argument-loop - (if (eolp) - (kill-region (point) (1+ (point))) - (kill-region (point) (if (search-forward ?\n nil t) - (1- (point)) (point-max)))))) - (defun set-auto-fill-hook (arg) (setq auto-fill-function (intern arg))) @@ -351,7 +344,7 @@ (setq count (1+ count))))) (defun ml-next-page () - (previous-page (- (ml-prefix-argument)))) + (ml-previous-page (- (ml-prefix-argument)))) (defun page-next-window (&optional arg) (let ((count (or arg (ml-prefix-argument)))) diff --git a/lisp/obsolete/rnews.el b/lisp/obsolete/rnews.el index bca9ea4824a..df1d386c77f 100644 --- a/lisp/obsolete/rnews.el +++ b/lisp/obsolete/rnews.el @@ -272,19 +272,6 @@ Type \\[describe-mode] once reading news to get a list of rnews commands." (news-push (cons news-current-news-group news-current-certifiable) news-current-certifications)))) -(defun news-set-minor-modes () - "Creates a minor mode list that has group name, total articles, -and attribute for current article." - (setq news-minor-modes (list (cons 'foo - (concat news-current-message-number - "/" - news-total-current-group - (news-get-attribute-string))))) - ;; Detect Emacs versions 18.16 and up, which display - ;; directly from news-minor-modes by using a list for mode-name. - (or (boundp 'minor-mode-alist) - (setq minor-modes news-minor-modes))) - (defun news-set-message-counters () "Scan through current news-groups filelist to figure out how many messages are there. Set counters for use with minor mode display." diff --git a/lisp/gnus/password.el b/lisp/password-cache.el index 32ab76052d9..eeaa31b9a31 100644 --- a/lisp/gnus/password.el +++ b/lisp/password-cache.el @@ -1,6 +1,7 @@ -;;; password.el --- Read passwords from user, possibly using a password cache. +;;; password-cache.el --- Read passwords, possibly using a password cache. -;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007 +;; Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon@josefsson.org> ;; Created: 2003-12-21 @@ -36,13 +37,6 @@ ;; (password-cache-add "test" "foo") ;; => nil -;; Note the previous two can be replaced with: -;; (password-read-and-add "Password? " "test") -;; ;; Minibuffer prompt for password. -;; => "foo" -;; ;; "foo" is now cached with key "test" - - ;; (password-read "Password? " "test") ;; ;; No minibuffer prompt ;; => "foo" @@ -59,9 +53,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defcustom password-cache t "Whether to cache passwords." :group 'password @@ -96,14 +87,20 @@ The variable `password-cache' control whether the cache is used." (defun password-read-and-add (prompt &optional key) "Read password, for use with KEY, from user, or from cache if wanted. Then store the password in the cache. Uses `password-read' and -`password-cache-add'. -Custom variables `password-cache' and `password-cache-expiry' -regulate cache behavior." +`password-cache-add'. Custom variables `password-cache' and +`password-cache-expiry' regulate cache behavior. + +Warning: the password is cached without checking that it is +correct. It is better to check the password before caching. If +you must use this function, take care to check passwords and +remove incorrect ones from the cache." (let ((password (password-read prompt key))) (when (and password key) (password-cache-add key password)) password)) +(make-obsolete 'password-read-and-add 'password-read "23.1") + (defun password-cache-remove (key) "Remove password indexed by KEY from password cache. This is typically run be a timer setup from `password-cache-add', @@ -120,8 +117,7 @@ user again." (defun password-cache-add (key password) "Add password to cache. -The password is removed by a timer after `password-cache-expiry' -seconds." +The password is removed by a timer after `password-cache-expiry' seconds." (when (and password-cache-expiry (null (intern-soft key password-data))) (run-at-time password-cache-expiry nil #'password-cache-remove @@ -134,7 +130,7 @@ seconds." (interactive) (fillarray password-data 0)) -(provide 'password) +(provide 'password-cache) ;;; arch-tag: ab160494-16c8-4c68-a4a1-73eebf6686e5 -;;; password.el ends here +;;; password-cache.el ends here diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 79b269870b1..8116ad91fd2 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -281,6 +281,10 @@ to all arguments, such as variable names after a $." :type 'hook :group 'pcomplete) +(defsubst pcomplete-executables (&optional regexp) + "Complete amongst a list of directories and executables." + (pcomplete-entries regexp 'file-executable-p)) + (defcustom pcomplete-command-completion-function (function (lambda () @@ -599,6 +603,8 @@ this is `comint-dynamic-complete-functions'." "Setup shell-mode to use pcomplete." (pcomplete-comint-setup 'shell-dynamic-complete-functions)) +(declare-function comint-bol "comint" (&optional arg)) + (defun pcomplete-parse-comint-arguments () "Parse whitespace separated arguments in the current region." (let ((begin (save-excursion (comint-bol nil) (point))) @@ -780,10 +786,6 @@ component, `default-directory' is used as the basis for completion." "Complete amongst a list of directories." (pcomplete-entries regexp 'file-directory-p)) -(defsubst pcomplete-executables (&optional regexp) - "Complete amongst a list of directories and executables." - (pcomplete-entries regexp 'file-executable-p)) - ;; generation of completion lists (defun pcomplete-find-completion-function (command) @@ -944,17 +946,16 @@ generate the completions list. This means that the hook ;; Abstractions so that the code below will work for both Emacs 20 and ;; XEmacs 21 -(unless (fboundp 'event-matches-key-specifier-p) - (defalias 'event-matches-key-specifier-p 'eq)) +(defalias 'pcomplete-event-matches-key-specifier-p + (if (featurep 'xemacs) + 'event-matches-key-specifier-p + 'eq)) (defun pcomplete-read-event (&optional prompt) (if (fboundp 'read-event) (read-event prompt) (aref (read-key-sequence prompt) 0))) -(unless (fboundp 'event-basic-type) - (defalias 'event-basic-type 'event-key)) - (defun pcomplete-show-completions (completions) "List in help buffer sorted COMPLETIONS. Typing SPC flushes the help buffer." @@ -973,13 +974,13 @@ Typing SPC flushes the help buffer." (while (with-current-buffer (get-buffer "*Completions*") (setq event (pcomplete-read-event))) (cond - ((event-matches-key-specifier-p event ?\s) + ((pcomplete-event-matches-key-specifier-p event ?\s) (set-window-configuration pcomplete-last-window-config) (setq pcomplete-last-window-config nil) (throw 'done nil)) - ((or (event-matches-key-specifier-p event 'tab) + ((or (pcomplete-event-matches-key-specifier-p event 'tab) ;; Needed on a terminal - (event-matches-key-specifier-p event 9)) + (pcomplete-event-matches-key-specifier-p event 9)) (let ((win (or (get-buffer-window "*Completions*" 0) (display-buffer "*Completions*" 'not-this-window)))) diff --git a/lisp/pcvs-parse.el b/lisp/pcvs-parse.el index 3ca1829030f..61ee7b4bea2 100644 --- a/lisp/pcvs-parse.el +++ b/lisp/pcvs-parse.el @@ -235,7 +235,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; servers, this should not be necessary, because they return ;; a complete merge output. (with-temp-buffer - (insert-file-contents path) + (ignore-errors (insert-file-contents path)) (goto-char (point-min)) (if (re-search-forward "^<<<<<<< " nil t) 'CONFLICT 'NEED-MERGE)))) @@ -272,8 +272,9 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; branches, or because it's been removed). (if (ignore-errors (with-temp-buffer - (insert-file-contents (expand-file-name - ".cvsignore" (file-name-directory dir))) + (ignore-errors + (insert-file-contents + (expand-file-name ".cvsignore" (file-name-directory dir)))) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote (file-name-nondirectory dir)) "/$") @@ -301,7 +302,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; [add] this will also show up as a `U <file>' (and - (cvs-match "\\(.*\\), version \\(.*\\), resurrected$" + (cvs-match "`?\\(.*?\\)'?, version \\(.*\\), resurrected$" (path 1) (base-rev 2)) ;; FIXME: resurrection only brings back the original version, ;; not the latest on the branch, so `up-to-date' is not always diff --git a/lisp/pcvs.el b/lisp/pcvs.el index a0bac0b2871..f9c71c34192 100644 --- a/lisp/pcvs.el +++ b/lisp/pcvs.el @@ -1457,7 +1457,9 @@ The POSTPROC specified there (typically `log-edit') is then called, (let ((buf (cvs-temp-buffer "message" 'normal 'nosetup)) (setupfun (or (nth 2 (cdr (assoc "message" cvs-buffer-name-alist))) 'log-edit))) - (funcall setupfun 'cvs-do-commit setup 'cvs-commit-filelist buf) + (funcall setupfun 'cvs-do-commit setup + '((log-edit-listfun . cvs-commit-filelist) + (log-edit-diff-function . cvs-mode-diff)) buf) (set (make-local-variable 'cvs-minor-wrap-function) 'cvs-commit-minor-wrap) (run-hooks 'cvs-mode-commit-hook))) @@ -1520,7 +1522,10 @@ This is best called from a `log-view-mode' buffer." ;; Set the filename before, so log-edit can correctly setup its ;; log-edit-initial-files variable. (set (make-local-variable 'cvs-edit-log-files) (list file))) - (funcall setupfun 'cvs-do-edit-log nil 'cvs-edit-log-filelist buf) + (funcall setupfun 'cvs-do-edit-log nil + '((log-edit-listfun . cvs-edit-log-filelist) + (log-edit-diff-function . cvs-mode-diff)) + buf) (when text (erase-buffer) (insert text)) (set (make-local-variable 'cvs-edit-log-revision) rev) (set (make-local-variable 'cvs-minor-wrap-function) @@ -1960,6 +1965,8 @@ This command ignores files that are not flagged as `Unknown'." (setf (cvs-fileinfo->type fi) 'DEAD)) (cvs-cleanup-collection cvs-cookies nil nil nil)) +(declare-function vc-editable-p "vc" (file)) +(declare-function vc-checkout "vc" (file &optional writable rev)) (defun cvs-append-to-ignore (dir str &optional old-dir) "Add STR to the .cvsignore file in DIR. @@ -2291,7 +2298,7 @@ this file, or a list of arguments to send to the program." (buffer (find-buffer-visiting file))) ;; For a revert to happen the user must be editing the file... (unless (or (null buffer) - (eq (cvs-fileinfo->type fileinfo) 'MESSAGE) + (memq (cvs-fileinfo->type fileinfo) '(MESSAGE UNKNOWN)) ;; FIXME: check whether revert is really needed. ;; `(verify-visited-file-modtime buffer)' doesn't cut it ;; because it only looks at the time stamp (it ignores diff --git a/lisp/pgg-parse.el b/lisp/pgg-parse.el index 11d0c652d34..336c492efde 100644 --- a/lisp/pgg-parse.el +++ b/lisp/pgg-parse.el @@ -178,6 +178,8 @@ (repeat)))) (repeat))))) + (defvar pgg-parse-crc24) + (defun pgg-parse-crc24-string (string) (let ((h (vector nil 183 1230 nil nil nil nil nil nil))) (ccl-execute-on-string pgg-parse-crc24 h string) @@ -463,6 +465,10 @@ pgg-parse-public-key-algorithm-alist))) result)) +;; p-d-p only calls this if it is defined, but the compiler does not +;; recognize that. +(declare-function pgg-parse-crc24-string "pgg-parse" (string)) + (defun pgg-decode-packets () (if (re-search-forward "^=\\([A-Za-z0-9+/]\\{4\\}\\)$" nil t) (let ((p (match-beginning 0)) diff --git a/lisp/pgg.el b/lisp/pgg.el index 13a5148d5cd..6e4a2a874ec 100644 --- a/lisp/pgg.el +++ b/lisp/pgg.el @@ -40,6 +40,84 @@ ;;; @ utility functions ;;; +(eval-when-compile + (unless (featurep 'xemacs) + (defalias 'pgg-run-at-time 'run-at-time) + (defalias 'pgg-cancel-timer 'cancel-timer)) + + (when (featurep 'xemacs) + (defmacro pgg-run-at-time-1 (time repeat function args) + (if (condition-case nil + (let ((delete-itimer 'delete-itimer) + (itimer-driver-start 'itimer-driver-start) + (itimer-value 'itimer-value) + (start-itimer 'start-itimer)) + (unless (or (symbol-value 'itimer-process) + (symbol-value 'itimer-timer)) + (funcall itimer-driver-start)) + ;; Check whether there is a bug to which the difference of + ;; the present time and the time when the itimer driver was + ;; woken up is subtracted from the initial itimer value. + (let* ((inhibit-quit t) + (ctime (current-time)) + (itimer-timer-last-wakeup + (prog1 + ctime + (setcar ctime (1- (car ctime))))) + (itimer-list nil) + (itimer (funcall start-itimer "pgg-run-at-time" + 'ignore 5))) + (sleep-for 0.1) ;; Accept the timeout interrupt. + (prog1 + (> (funcall itimer-value itimer) 0) + (funcall delete-itimer itimer)))) + (error nil)) + `(let ((time ,time)) + (apply #'start-itimer "pgg-run-at-time" + ,function (if time (max time 1e-9) 1e-9) + ,repeat nil t ,args))) + `(let ((time ,time) + (itimers (list nil))) + (setcar + itimers + (apply #'start-itimer "pgg-run-at-time" + (lambda (itimers repeat function &rest args) + (let ((itimer (car itimers))) + (if repeat + (progn + (set-itimer-function + itimer + (lambda (itimer repeat function &rest args) + (set-itimer-restart itimer repeat) + (set-itimer-function itimer function) + (set-itimer-function-arguments itimer args) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer repeat function) args))) + (set-itimer-function + itimer + (lambda (itimer function &rest args) + (delete-itimer itimer) + (apply function args))) + (set-itimer-function-arguments + itimer + (append (list itimer function) args))))) + 1e-9 (if time (max time 1e-9) 1e-9) + nil t itimers ,repeat ,function ,args)))) + + (defun pgg-run-at-time (time repeat function &rest args) + "Emulating function run as `run-at-time'. +TIME should be nil meaning now, or a number of seconds from now. +Return an itimer object which can be used in either `delete-itimer' +or `cancel-timer'." + (pgg-run-at-time-1 time repeat function args)) + (defun pgg-cancel-timer (timer) + "Emulate cancel-timer for xemacs." + (let ((delete-itimer 'delete-itimer)) + (funcall delete-itimer timer))) + )) + (defun pgg-invoke (func scheme &rest args) (progn (require (intern (format "pgg-%s" scheme))) @@ -153,6 +231,8 @@ regulate cache behavior." (defun pgg-clear-string (string) (fillarray string ?_))) +(declare-function pgg-clear-string "pgg" (string)) + (defun pgg-remove-passphrase-from-cache (key &optional notruncate) "Omit passphrase associated with KEY in time-limited passphrase cache. @@ -177,85 +257,6 @@ regulate cache behavior." (pgg-cancel-timer old-timer) (unintern interned-timer-key pgg-pending-timers)))) -(eval-when-compile - (defmacro pgg-run-at-time-1 (time repeat function args) - (when (featurep 'xemacs) - (if (condition-case nil - (let ((delete-itimer 'delete-itimer) - (itimer-driver-start 'itimer-driver-start) - (itimer-value 'itimer-value) - (start-itimer 'start-itimer)) - (unless (or (symbol-value 'itimer-process) - (symbol-value 'itimer-timer)) - (funcall itimer-driver-start)) - ;; Check whether there is a bug to which the difference of - ;; the present time and the time when the itimer driver was - ;; woken up is subtracted from the initial itimer value. - (let* ((inhibit-quit t) - (ctime (current-time)) - (itimer-timer-last-wakeup - (prog1 - ctime - (setcar ctime (1- (car ctime))))) - (itimer-list nil) - (itimer (funcall start-itimer "pgg-run-at-time" - 'ignore 5))) - (sleep-for 0.1) ;; Accept the timeout interrupt. - (prog1 - (> (funcall itimer-value itimer) 0) - (funcall delete-itimer itimer)))) - (error nil)) - `(let ((time ,time)) - (apply #'start-itimer "pgg-run-at-time" - ,function (if time (max time 1e-9) 1e-9) - ,repeat nil t ,args))) - `(let ((time ,time) - (itimers (list nil))) - (setcar - itimers - (apply #'start-itimer "pgg-run-at-time" - (lambda (itimers repeat function &rest args) - (let ((itimer (car itimers))) - (if repeat - (progn - (set-itimer-function - itimer - (lambda (itimer repeat function &rest args) - (set-itimer-restart itimer repeat) - (set-itimer-function itimer function) - (set-itimer-function-arguments itimer args) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer repeat function) args))) - (set-itimer-function - itimer - (lambda (itimer function &rest args) - (delete-itimer itimer) - (apply function args))) - (set-itimer-function-arguments - itimer - (append (list itimer function) args))))) - 1e-9 (if time (max time 1e-9) 1e-9) - nil t itimers ,repeat ,function ,args)))))) - -(eval-and-compile - (if (featurep 'xemacs) - (progn - (defun pgg-run-at-time (time repeat function &rest args) - "Emulating function run as `run-at-time'. -TIME should be nil meaning now, or a number of seconds from now. -Return an itimer object which can be used in either `delete-itimer' -or `cancel-timer'." - (pgg-run-at-time-1 time repeat function args)) - (defun pgg-cancel-timer (timer) - "Emulate cancel-timer for xemacs." - (let ((delete-itimer 'delete-itimer)) - (funcall delete-itimer timer))) - ) - (defalias 'pgg-run-at-time 'run-at-time) - (defalias 'pgg-cancel-timer 'cancel-timer))) - (defmacro pgg-convert-lbt-region (start end lbt) `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) (goto-char ,start) diff --git a/lisp/play/blackbox.el b/lisp/play/blackbox.el index 699aa91abcf..48a6e4bd046 100644 --- a/lisp/play/blackbox.el +++ b/lisp/play/blackbox.el @@ -296,14 +296,14 @@ a reflection." (defun bb-up (count) (interactive "p") (while (and (> count 0) (> bb-y -1)) - (forward-line -1) + (with-no-warnings (previous-line)) (setq bb-y (1- bb-y)) (setq count (1- count)))) (defun bb-down (count) (interactive "p") (while (and (> count 0) (< bb-y 8)) - (forward-line 1) + (with-no-warnings (next-line)) (setq bb-y (1+ bb-y)) (setq count (1- count)))) diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index a1f8c2708d2..95c16849dce 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -1,4 +1,4 @@ -;;; dunnet.el --- text adventure for Emacs +;;; dunnet.el --- text adventure for Emacs -*- byte-compile-warnings: nil -*- ;; Copyright (C) 1992, 1993, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007 Free Software Foundation, Inc. @@ -46,12 +46,6 @@ :type 'file :group 'dunnet) -(if nil - (eval-and-compile (setq byte-compile-warnings nil))) - -(eval-when-compile - (require 'cl)) - ;;;; Mode definitions for interactive mode (define-derived-mode dun-mode text-mode "Dungeon" @@ -63,18 +57,19 @@ "Function called when return is pressed in interactive mode to parse line." (interactive "*p") (beginning-of-line) - (setq beg (+ (point) 1)) - (end-of-line) - (if (and (not (= beg (point))) (not (< (point) beg)) - (string= ">" (buffer-substring (- beg 1) beg))) - (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) - (dun-mprinc "I don't understand that.\n"))) + (let ((beg (1+ (point))) + line) + (end-of-line) + (if (and (not (= beg (point))) (not (< (point) beg)) + (string= ">" (buffer-substring (- beg 1) beg))) + (progn + (setq line (downcase (buffer-substring beg (point)))) + (princ line) + (if (eq (dun-vparse dun-ignore dun-verblist line) -1) + (dun-mprinc "I don't understand that.\n"))) (goto-char (point-max)) - (dun-mprinc "\n")) - (dun-messages)) + (dun-mprinc "\n"))) + (dun-messages)) (defun dun-messages () (if dun-dead diff --git a/lisp/play/yow.el b/lisp/play/yow.el index 28fc453577b..702052f52d6 100644 --- a/lisp/play/yow.el +++ b/lisp/play/yow.el @@ -112,6 +112,8 @@ If called interactively, display a list of matches." ;; ;; written by Kayvan Aghaiepour +(declare-function doctor-ret-or-read "doctor" (arg)) + ;;;###autoload (defun psychoanalyze-pinhead () "Zippy goes to the analyst." diff --git a/lisp/progmodes/antlr-mode.el b/lisp/progmodes/antlr-mode.el index 01f1c86618c..9f6e70dcce5 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -840,7 +840,8 @@ Do not change." (defface antlr-keyword (cond-emacs-xemacs '((((class color) (background light)) - (:foreground "black" :EMACS :weight bold :XEMACS :bold t)))) + (:foreground "black" :EMACS :weight bold :XEMACS :bold t)) + (t :inherit font-lock-keyword-face))) "ANTLR keywords." :group 'antlr) ;; backward-compatibility alias @@ -850,7 +851,8 @@ Do not change." (defface antlr-syntax (cond-emacs-xemacs '((((class color) (background light)) - (:foreground "black" :EMACS :weight bold :XEMACS :bold t)))) + (:foreground "black" :EMACS :weight bold :XEMACS :bold t)) + (t :inherit font-lock-constant-face))) "ANTLR syntax symbols like :, |, (, ), ...." :group 'antlr) ;; backward-compatibility alias @@ -860,7 +862,8 @@ Do not change." (defface antlr-ruledef (cond-emacs-xemacs '((((class color) (background light)) - (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)))) + (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)) + (t :inherit font-lock-function-name-face))) "ANTLR rule references (definition)." :group 'antlr) ;; backward-compatibility alias @@ -870,7 +873,8 @@ Do not change." (defface antlr-tokendef (cond-emacs-xemacs '((((class color) (background light)) - (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)))) + (:foreground "blue" :EMACS :weight bold :XEMACS :bold t)) + (t :inherit font-lock-function-name-face))) "ANTLR token references (definition)." :group 'antlr) ;; backward-compatibility alias @@ -878,7 +882,8 @@ Do not change." (defvar antlr-ruleref-face 'antlr-ruleref) (defface antlr-ruleref - '((((class color) (background light)) (:foreground "blue4"))) + '((((class color) (background light)) (:foreground "blue4")) + (t :inherit font-lock-type-face)) "ANTLR rule references (usage)." :group 'antlr) ;; backward-compatibility alias @@ -886,7 +891,8 @@ Do not change." (defvar antlr-tokenref-face 'antlr-tokenref) (defface antlr-tokenref - '((((class color) (background light)) (:foreground "orange4"))) + '((((class color) (background light)) (:foreground "orange4")) + (t :inherit font-lock-type-face)) "ANTLR token references (usage)." :group 'antlr) ;; backward-compatibility alias @@ -896,7 +902,8 @@ Do not change." (defface antlr-literal (cond-emacs-xemacs '((((class color) (background light)) - (:foreground "brown4" :EMACS :weight bold :XEMACS :bold t)))) + (:foreground "brown4" :EMACS :weight bold :XEMACS :bold t)) + (t :inherit font-lock-string-face))) "ANTLR special literal tokens. It is used to highlight strings matched by the first regexp group of `antlr-font-lock-literal-regexp'." diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index a019f598918..7666da75f9b 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -604,7 +604,7 @@ comment at the start of cc-engine.el for more info." ;; (e.g. if). ;; ;; - ;; The following diagram briefly outlines the PDA. + ;; The following diagram briefly outlines the PDA. ;; ;; Common state: ;; "else": Push state, goto state `else'. @@ -1079,7 +1079,7 @@ single `?' is found, then `c-maybe-labelp' is cleared. For AWK, a statement which is terminated by an EOL (not a \; or a }) is regarded as having a \"virtual semicolon\" immediately after the last token on -the line. If this virtual semicolon is _at_ from, the function recognises it. +the line. If this virtual semicolon is _at_ from, the function recognizes it. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." @@ -1916,7 +1916,7 @@ comment at the start of cc-engine.el for more info." (defun c-partial-ws-p (beg end) ;; Is the region (beg end) WS, and is there WS (or BOB/EOB) next to the ;; region? This is a "heuristic" function. ..... - ;; + ;; ;; The motivation for the second bit is to check whether removing this ;; region would coalesce two symbols. ;; @@ -3291,7 +3291,7 @@ comment at the start of cc-engine.el for more info." ;; The workaround for this is for the AWK Mode initialisation to switch the ;; defalias for c-in-literal to c-slow-in-literal. This will slow down other ;; cc-modes in Xemacs whenever an awk-buffer has been initialised. -;; +;; ;; (Alan Mackenzie, 2003/4/30). (defun c-fast-in-literal (&optional lim detect-cpp) @@ -3406,7 +3406,7 @@ comment at the start of cc-engine.el for more info." (if (and (consp range) (progn (goto-char (car range)) (looking-at c-line-comment-starter))) - (let ((col (current-column)) + (let ((col (current-column)) (beg (point)) (bopl (c-point 'bopl)) (end (cdr range))) @@ -4045,7 +4045,7 @@ comment at the start of cc-engine.el for more info." ;; example, this happens to "foo" when "foo \n bar();" becomes ;; "foo(); \n bar();". Such stale types, if not removed, foul up ;; the fontification. - ;; + ;; ;; Have we, perhaps, added non-ws characters to the front/back of a found ;; type? (when (> end beg) @@ -4064,7 +4064,7 @@ comment at the start of cc-engine.el for more info." (c-beginning-of-current-token))) (c-unfind-type (buffer-substring-no-properties (point) beg)))))) - + (if c-maybe-stale-found-type ; e.g. (c-decl-id-start "foo" 97 107 " (* ooka) " "o") (cond ;; Changing the amount of (already existing) whitespace - don't do anything. @@ -5929,7 +5929,7 @@ comment at the start of cc-engine.el for more info." macro-start ; if we're in one. label-type) (cond - ;; "case" or "default" (Doesn't apply to AWK). + ;; "case" or "default" (Doesn't apply to AWK). ((looking-at c-label-kwds-regexp) (let ((kwd-end (match-end 1))) ;; Record only the keyword itself for fontification, since in @@ -6048,7 +6048,7 @@ comment at the start of cc-engine.el for more info." (c-forward-label nil pte start)))))))))) ;; Point is still at the beginning of the possible label construct. - ;; + ;; ;; Check that the next nonsymbol token is ":", or that we're in one ;; of QT's "slots" declarations. Allow '(' for the sake of macro ;; arguments. FIXME: Should build this regexp from the language @@ -6074,7 +6074,7 @@ comment at the start of cc-engine.el for more info." (and (c-major-mode-is 'c++-mode) (string-match "\\(p\\(r\\(ivate\\|otected\\)\\|ublic\\)\\|more\\)\\>" - (buffer-substring start (point))))) + (buffer-substring start (point))))) (c-forward-syntactic-ws limit) (cond ((looking-at ":\\([^:]\\|\\'\\)") ; A single colon. @@ -7238,7 +7238,7 @@ comment at the start of cc-engine.el for more info." ;; needed with further syntax elements of the types `substatement', ;; `inexpr-statement', `arglist-cont-nonempty', `statement-block-intro', and ;; `defun-block-intro'. - ;; + ;; ;; Do the generic processing to anchor the given syntax symbol on ;; the preceding statement: Skip over any labels and containing ;; statements on the same line, and then search backward until we @@ -7424,7 +7424,7 @@ comment at the start of cc-engine.el for more info." c-other-decl-block-key-in-symbols-alist)) (max (c-point 'boi paren-pos) (point)))) (t (c-add-syntax 'defun-block-intro nil)))) - + (c-add-syntax 'statement-block-intro nil))) (if (= paren-pos boi) @@ -8264,7 +8264,7 @@ comment at the start of cc-engine.el for more info." 'statement-cont) nil nil containing-sexp paren-state)) )) - + ;; CASE 5F: Close of a non-class declaration level block. ((and (eq char-after-ip ?}) (c-keyword-member containing-decl-kwd diff --git a/lisp/progmodes/cc-subword.el b/lisp/progmodes/cc-subword.el index 68ecd3a0515..d3e613fa254 100644 --- a/lisp/progmodes/cc-subword.el +++ b/lisp/progmodes/cc-subword.el @@ -123,6 +123,8 @@ telling us which (X)Emacs version you're using." map) "Keymap used in command `c-subword-mode' minor mode.") + ;; Produces compiler warning about make-variable-buffer-local not + ;; being called at toplevel (due to fboundp test). (define-minor-mode c-subword-mode "Mode enabling subword movement and editing keys. In spite of GNU Coding Standards, it is popular to name a symbol by diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 3de5b7eeb7e..b4148c59b49 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -339,6 +339,57 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?" nil 2 nil 2 nil (0 'default t) (1 compilation-error-face prepend) (2 compilation-line-face prepend)) + + (compilation-perl--Pod::Checker + ;; podchecker error messages, per Pod::Checker. + ;; The style is from the Pod::Checker::poderror() function, eg. + ;; *** ERROR: Spurious text after =cut at line 193 in file foo.pm + ;; + ;; Plus end_pod() can give "at line EOF" instead of a + ;; number, so for that match "on line N" which is the + ;; originating spot, eg. + ;; *** ERROR: =over on line 37 without closing =back at line EOF in file bar.pm + ;; + ;; Plus command() can give both "on line N" and "at line N"; + ;; the latter is desired and is matched because the .* is + ;; greedy. + ;; *** ERROR: =over on line 1 without closing =back (at head1) at line 3 in file x.pod + ;; + "^\\*\\*\\* \\(?:ERROR\\|\\(WARNING\\)\\).* \\(?:at\\|on\\) line \ +\\([0-9]+\\) \\(?:.* \\)?in file \\([^ \t\n]+\\)" + 3 2 nil (1)) + (compilation-perl--Test + ;; perl Test module error messages. + ;; Style per the ok() function "$context", eg. + ;; # Failed test 1 in foo.t at line 6 + ;; + "^# Failed test [0-9]+ in \\([^ \t\r\n]+\\) at line \\([0-9]+\\)" + 1 2) + (compilation-perl--Test::Harness + ;; perl Test::Harness output, eg. + ;; NOK 1# Test 1 got: "1234" (t/foo.t at line 46) + ;; + ;; Test::Harness is slightly designed for tty output, since + ;; it prints CRs to overwrite progress messages, but if you + ;; run it in with M-x compile this pattern can at least step + ;; through the failures. + ;; + "^.*NOK.* \\([^ \t\r\n]+\\) at line \\([0-9]+\\)" + 1 2) + (compilation-weblint + ;; The style comes from HTML::Lint::Error::as_string(), eg. + ;; index.html (13:1) Unknown element <fdjsk> + ;; + ;; The pattern only matches filenames without spaces, since that + ;; should be usual and should help reduce the chance of a false + ;; match of a message from some unrelated program. + ;; + ;; This message style is quite close to the "ibm" entry which is + ;; for IBM C, though that ibm bit doesn't put a space after the + ;; filename. + ;; + "^\\([^ \t\r\n(]+\\) (\\([0-9]+\\):\\([0-9]+\\)) " + 1 2 3) ) "Alist of values for `compilation-error-regexp-alist'.") diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 13f1e0c24b8..4a397a9d012 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1510,6 +1510,8 @@ the last)." 2 3)) "Alist that specifies how to match errors in perl output.") +(defvar compilation-error-regexp-alist) + ;;;###autoload (defun cperl-mode () "Major mode for editing Perl code. @@ -1790,9 +1792,11 @@ or as help on variables `cperl-tips', `cperl-problems', (set 'vc-sccs-header cperl-vc-sccs-header) ;; This one is obsolete... (make-local-variable 'vc-header-alist) - (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning - `((SCCS ,(car cperl-vc-sccs-header)) - (RCS ,(car cperl-vc-rcs-header))))) + (with-no-warnings + (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning + `((SCCS ,(car cperl-vc-sccs-header)) + (RCS ,(car cperl-vc-rcs-header))))) + ) (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x (make-local-variable 'compilation-error-regexp-alist-alist) (set 'compilation-error-regexp-alist-alist diff --git a/lisp/progmodes/dcl-mode.el b/lisp/progmodes/dcl-mode.el index 6a3e9e82d6e..4546880cca5 100644 --- a/lisp/progmodes/dcl-mode.el +++ b/lisp/progmodes/dcl-mode.el @@ -2201,6 +2201,7 @@ otherwise return nil." () (equal start (match-end 0)))))) +(declare-function imenu-default-create-index-function "imenu" ()) ;;;------------------------------------------------------------------------- (defun dcl-imenu-create-index-function () diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 5538bd8984a..1e144282de5 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -1268,10 +1268,9 @@ For the format of LINE-ERR-INFO, see `flymake-ler-make-ler'." (defun flymake-goto-file-and-line (file line) "Try to get buffer for FILE and goto line LINE in it." (if (not (file-exists-p file)) - (flymake-log 1 "file %s does not exists" file) - (progn - (find-file file) - (goto-line line)))) + (flymake-log 1 "File %s does not exist" file) + (find-file file) + (goto-line line))) ;; flymake minor mode declarations (defvar flymake-mode-line nil) diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 43cb61cba6b..1954319269d 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -908,6 +908,8 @@ affects all Fortran buffers, and also the default." "Fortran mode adds this to `hack-local-variables-hook'." (fortran-line-length fortran-line-length)) +(declare-function gud-find-c-expr "gud.el" nil) + (defun fortran-gud-find-expr () ;; Consider \n as punctuation (end of expression). (with-syntax-table fortran-gud-syntax-table diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el index 0d1a4b05d65..32db8850b66 100644 --- a/lisp/progmodes/gdb-ui.el +++ b/lisp/progmodes/gdb-ui.el @@ -43,12 +43,22 @@ ;; section in the GDB info manual. ;; GDB developers plan to make the annotation interface obsolete. A new -;; interface called GDB/MI (machine interface) has been designed to replace -;; it. Some GDB/MI commands are used in this file through the CLI command -;; 'interpreter mi <mi-command>'. A file called gdb-mi.el is included with -;; GDB (6.2 onwards) that uses GDB/MI as the primary interface to GDB. It is -;; still under development and is part of a process to migrate Emacs from -;; annotations to GDB/MI. +;; interface called GDB/MI (machine interface) has been designed to replace it. +;; Some GDB/MI commands are used in this file through the CLI command +;; 'interpreter mi <mi-command>'. To help with the process of fully migrating +;; Emacs from annotations to GDB/MI, there is an experimental package called +;; gdb-mi in the Emacs Lisp Package Archive ("http://tromey.com/elpa/"). It +;; comprises of modified gud.el and a file called gdb-mi.el which replaces +;; gdb-ui.el. When installed, this overrides the current files and invoking +;; M-x gdb will use GDB/MI directly (starts with "gdb -i=mi"). When deleted +;; ('d' followed by 'x' in Package Menu mode), the files are deleted and old +;; functionality restored. This provides a convenient way to review the +;; current status/contribute to its improvement. For someone who just wants to +;; use GDB, however, the current mode in Emacs 22 is a much better option. +;; There is also a file, also called gdb-mi.el, a version of which is included +;; the GDB distribution. This will probably only work with versions +;; distributed with GDB 6.5 or later. Unlike the version in ELPA it works on +;; top of gdb-ui.el and you can only start it with M-x gdbmi. ;; This mode SHOULD WORK WITH GDB 5.0 or later but you will NEED AT LEAST ;; GDB 6.0 to use watch expressions. It works best with GDB 6.4 or later @@ -69,25 +79,13 @@ ;;; Known Bugs: -;; 1) Strings that are watched don't update in the speedbar when their -;; contents change unless the first character changes. -;; 2) Cannot handle multiple debug sessions. -;; 3) M-x gdb doesn't work with "run" command in .gdbinit, use M-x gdba instead. -;; 4) M-x gdb doesn't work if the corefile is specified in the command in the -;; minibuffer, use M-x gdba instead (or specify the core in the GUD buffer). -;; 5) If you wish to call procedures from your program in GDB +;; 1) Cannot handle multiple debug sessions. +;; 2) If you wish to call procedures from your program in GDB ;; e.g "call myproc ()", "p mysquare (5)" then use level 2 annotations ;; "gdb --annotate=2 myprog" to keep source buffer/selected frame fixed. -;; 6) After detaching from a process, clicking on the "GO" icon on toolbar +;; 3) After detaching from a process, clicking on the "GO" icon on toolbar ;; (gud-go) sends "continue" to GDB (should be "run"). -;;; Problems with watch expressions, GDB/MI: - -;; 1) They go out of scope when the inferior is re-run. -;; 2) -stack-list-locals has a type field but also prints type in values field. -;; 3) VARNUM increments even when variable object is not created -;; (maybe trivial). - ;;; TODO: ;; 1) Use MI command -data-read-memory for memory window. @@ -138,6 +136,7 @@ Emacs can't find.") (defvar gdb-frame-begin nil "Non-nil when GDB generates frame-begin annotation.") (defvar gdb-printing t) +(defvar gdb-parent-bptno-enabled nil) (defvar gdb-buffer-type nil "One of the symbols bound in `gdb-buffer-rules'.") @@ -222,7 +221,6 @@ handlers.") The directory containing FILE becomes the initial working directory and source-file directory for your debugger. - If `gdb-many-windows' is nil (the default value) then gdb just pops up the GUD buffer unless `gdb-show-main' is t. In this case it starts with two windows: one displaying the GUD buffer and the @@ -1860,7 +1858,7 @@ static char *magick[] = { :group 'gud) (defconst gdb-breakpoint-regexp - "\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\s-+\\(.\\)\\s-+") + "\\(?:\\([0-9]+\\).*?\\(?:point\\|catch\\s-+\\S-+\\)\\s-+\\S-+\\|\\([0-9]+\\.[0-9]+\\)\\)\\s-+\\(.\\)\\s-+") ;; Put breakpoint icons in relevant margins (even those set in the GUD buffer). (defun gdb-info-breakpoints-custom () @@ -1879,10 +1877,12 @@ static char *magick[] = { (forward-line 1) (if (looking-at gdb-breakpoint-regexp) (progn - (setq bptno (match-string 1)) - (setq flag (char-after (match-beginning 2))) + (setq bptno (or (match-string 1) (match-string 2))) + (setq flag (char-after (match-beginning 3))) + (if (match-string 1) + (setq gdb-parent-bptno-enabled (eq flag ?y))) (add-text-properties - (match-beginning 2) (match-end 2) + (match-beginning 3) (match-end 3) (if (eq flag ?y) '(face font-lock-warning-face) '(face font-lock-type-face))) @@ -1938,6 +1938,9 @@ static char *magick[] = { (end-of-line)))))) (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom))) +(declare-function gud-remove "gdb-ui" t t) ; gud-def +(declare-function gud-break "gdb-ui" t t) ; gud-def + (defun gdb-mouse-set-clear-breakpoint (event) "Set/clear breakpoint in left fringe/margin with mouse click." (interactive "e") @@ -1963,17 +1966,18 @@ static char *magick[] = { (save-excursion (goto-char (posn-point posn)) (if (posn-object posn) - (gdb-enqueue-input - (list - (let ((bptno (get-text-property - 0 'gdb-bptno (car (posn-string posn))))) + (let* ((bptno (get-text-property + 0 'gdb-bptno (car (posn-string posn))))) + (string-match "\\([0-9+]\\)*" bptno) + (gdb-enqueue-input + (list (concat gdb-server-prefix (if (get-text-property 0 'gdb-enabled (car (posn-string posn))) "disable " "enable ") - bptno "\n")) - 'ignore)))))))) + (match-string 1 bptno) "\n") + 'ignore))))))))) (defun gdb-mouse-toggle-breakpoint-fringe (event) "Enable/disable breakpoint in left fringe with mouse click." @@ -1991,14 +1995,16 @@ static char *magick[] = { (when (overlay-get overlay 'put-break) (setq obj (overlay-get overlay 'before-string)))) (when (stringp obj) - (gdb-enqueue-input - (list - (concat gdb-server-prefix - (if (get-text-property 0 'gdb-enabled obj) - "disable " - "enable ") - (get-text-property 0 'gdb-bptno obj) "\n") - 'ignore)))))))) + (let* ((bptno (get-text-property 0 'gdb-bptno obj))) + (string-match "\\([0-9+]\\)*" bptno) + (gdb-enqueue-input + (list + (concat gdb-server-prefix + (if (get-text-property 0 'gdb-enabled obj) + "disable " + "enable ") + (match-string 1 bptno) "\n") + 'ignore))))))))) (defun gdb-breakpoints-buffer-name () (with-current-buffer gud-comint-buffer @@ -2064,21 +2070,25 @@ static char *magick[] = { (gdb-enqueue-input (list (concat gdb-server-prefix - (if (eq ?y (char-after (match-beginning 2))) + (if (eq ?y (char-after (match-beginning 3))) "disable " "enable ") - (match-string 1) "\n") 'ignore)) + (or (match-string 1) (match-string 2)) "\n") 'ignore)) (error "Not recognized as break/watchpoint line")))) (defun gdb-delete-breakpoint () "Delete the breakpoint at current line." (interactive) - (beginning-of-line 1) - (if (looking-at gdb-breakpoint-regexp) - (gdb-enqueue-input - (list - (concat gdb-server-prefix "delete " (match-string 1) "\n") 'ignore)) - (error "Not recognized as break/watchpoint line"))) + (save-excursion + (beginning-of-line 1) + (if (looking-at gdb-breakpoint-regexp) + (if (match-string 1) + (gdb-enqueue-input + (list + (concat gdb-server-prefix "delete " (match-string 1) "\n") + 'ignore)) + (message-box "This breakpoint cannot be deleted on its own.")) + (error "Not recognized as break/watchpoint line")))) (defun gdb-goto-breakpoint (&optional event) "Display the breakpoint location specified at current line." @@ -2086,7 +2096,7 @@ static char *magick[] = { (if event (posn-set-point (event-end event))) (save-excursion (beginning-of-line 1) - (if (looking-at "\\([0-9]+\\) .+ in .+ at\\s-+\\(\\S-+\\):\\([0-9]+\\)") + (if (looking-at "\\([0-9]+\\.?[0-9]*\\) .+ in .+ at\\s-+\\(\\S-+\\):\\([0-9]+\\)") (let ((bptno (match-string 1)) (file (match-string 2)) (line (match-string 3))) @@ -3156,6 +3166,8 @@ BUFFER nil or omitted means use the current buffer." (delete-overlay overlay)))) (defun gdb-put-breakpoint-icon (enabled bptno) + (if (string-match "[0-9+]+\\." bptno) + (setq enabled gdb-parent-bptno-enabled)) (let ((start (- (line-beginning-position) 1)) (end (+ (line-end-position) 1)) (putstring (if enabled "B" "b")) @@ -3215,8 +3227,8 @@ BUFFER nil or omitted means use the current buffer." (setq left-margin-width 2) (let ((window (get-buffer-window (current-buffer) 0))) (if window - (set-window-margins - window left-margin-width right-margin-width))))) + (set-window-margins + window left-margin-width right-margin-width))))) (gdb-put-string (propertize putstring 'face (if enabled 'breakpoint-enabled 'breakpoint-disabled)) @@ -3286,18 +3298,16 @@ BUFFER nil or omitted means use the current buffer." (goto-char (point-min)) (while (< (point) (- (point-max) 1)) (forward-line 1) - (if (looking-at "[^\t].*?breakpoint") - (progn - (looking-at - "\\([0-9]+\\)\\s-+\\S-+\\s-+\\S-+\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)") - (setq bptno (match-string 1)) - (setq flag (char-after (match-beginning 2))) - (setq address (match-string 3)) - (with-current-buffer buffer - (save-excursion - (goto-char (point-min)) - (if (search-forward address nil t) - (gdb-put-breakpoint-icon (eq flag ?y) bptno)))))))) + (when (looking-at + "\\([0-9]+\\.?[0-9]*\\).*?\\s-+\\(.\\)\\s-+0x0*\\(\\S-+\\)") + (setq bptno (match-string 1)) + (setq flag (char-after (match-beginning 2))) + (setq address (match-string 3)) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (if (search-forward address nil t) + (gdb-put-breakpoint-icon (eq flag ?y) bptno))))))) (if (not (equal gdb-pc-address "main")) (with-current-buffer buffer (set-window-point (get-buffer-window buffer 0) pos))))) @@ -3458,7 +3468,7 @@ is set in them." (gdb-force-mode-line-update (propertize "ready" 'face font-lock-variable-name-face))) -; Uses "-var-list-children --all-values". Needs GDB 6.1 onwards. +; Uses "-var-list-children --all-values". Needs GDB 6.4 onwards. (defun gdb-var-list-children-1 (varnum) (gdb-enqueue-input (list diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 091735ee09d..f811fce6e7f 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -333,6 +333,12 @@ This variable's value takes effect when `grep-compute-defaults' is called.") This variable's value takes effect when `grep-compute-defaults' is called.") ;;;###autoload +(defvar xargs-program "xargs" + "The default xargs program for `grep-find-command'. +See `grep-find-use-xargs'. +This variable's value takes effect when `grep-compute-defaults' is called.") + +;;;###autoload (defvar grep-find-use-xargs nil "Non-nil means that `grep-find' uses the `xargs' utility by default. If `exec', use `find -exec'. @@ -365,11 +371,16 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." (unless (or (not grep-highlight-matches) (eq grep-highlight-matches t)) (grep-compute-defaults)) (when (eq grep-highlight-matches t) - ;; Modify `process-environment' locally bound in `compilation-start' - (setenv "GREP_OPTIONS" (concat (getenv "GREP_OPTIONS") " --color=always")) - ;; for GNU grep 2.5.1 + ;; `setenv' modifies `process-environment' let-bound in `compilation-start' + ;; Any TERM except "dumb" allows GNU grep to use `--color=auto' + (setenv "TERM" "emacs-grep") + ;; `--color=auto' emits escape sequences on a tty rather than on a pipe, + ;; thus allowing to use multiple grep filters on the command line + ;; and to output escape sequences only on the final grep output + (setenv "GREP_OPTIONS" (concat (getenv "GREP_OPTIONS") " --color=auto")) + ;; GREP_COLOR is used in GNU grep 2.5.1, but deprecated in later versions (setenv "GREP_COLOR" "01;31") - ;; for GNU grep 2.5.1-cvs + ;; GREP_COLORS is used in GNU grep 2.5.2 and later versions (setenv "GREP_COLORS" "mt=01;31:fn=:ln=:bn=:se=:ml=:cx=:ne")) (set (make-local-variable 'compilation-exit-message-function) (lambda (status code msg) @@ -475,15 +486,15 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." (cond ((and (grep-probe find-program `(nil nil nil ,null-device "-print0")) - (grep-probe "xargs" `(nil nil nil "-0" "-e" "echo"))) + (grep-probe xargs-program `(nil nil nil "-0" "-e" "echo"))) 'gnu) (t 'exec)))) (unless grep-find-command (setq grep-find-command (cond ((eq grep-find-use-xargs 'gnu) - (format "%s . -type f -print0 | xargs -0 -e %s" - find-program grep-command)) + (format "%s . -type f -print0 | %s -0 -e %s" + find-program xargs-program grep-command)) ((eq grep-find-use-xargs 'exec) (let ((cmd0 (format "%s . -type f -exec %s" find-program grep-command))) @@ -493,22 +504,22 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." (shell-quote-argument ";")) (1+ (length cmd0))))) (t - (format "%s . -type f -print | xargs %s" - find-program grep-command))))) + (format "%s . -type f -print | %s %s" + find-program xargs-program grep-command))))) (unless grep-find-template (setq grep-find-template (let ((gcmd (format "%s <C> %s <R>" grep-program grep-options))) (cond ((eq grep-find-use-xargs 'gnu) - (format "%s . <X> -type f <F> -print0 | xargs -0 -e %s" - find-program gcmd)) + (format "%s . <X> -type f <F> -print0 | %s -0 -e %s" + find-program xargs-program gcmd)) ((eq grep-find-use-xargs 'exec) (format "%s . <X> -type f <F> -exec %s {} %s %s" find-program gcmd null-device (shell-quote-argument ";"))) (t - (format "%s . <X> -type f <F> -print | xargs %s" - find-program gcmd)))))))) + (format "%s . <X> -type f <F> -print | %s %s" + find-program xargs-program gcmd)))))))) (unless (or (not grep-highlight-matches) (eq grep-highlight-matches t)) (setq grep-highlight-matches (with-temp-buffer @@ -543,7 +554,7 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." "")) (defun grep-default-command () - "Compute the default grep command for C-u M-x grep to offer." + "Compute the default grep command for \\[universal-argument] \\[grep] to offer." (let ((tag-default (shell-quote-argument (grep-tag-default))) ;; This a regexp to match single shell arguments. ;; Could someone please add comments explaining it? @@ -596,19 +607,19 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." "Run grep, with user-specified args, and collect output in a buffer. While grep runs asynchronously, you can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] in the grep \ -output buffer, to go to the lines -where grep found matches. +output buffer, to go to the lines where grep +found matches. For doing a recursive `grep', see the `rgrep' command. For running `grep' in a specific directory, see `lgrep'. -This command uses a special history list for its COMMAND-ARGS, so you can -easily repeat a grep command. +This command uses a special history list for its COMMAND-ARGS, so you +can easily repeat a grep command. A prefix argument says to default the argument based upon the current tag the cursor is over, substituting it into the last grep command -in the grep command history (or into `grep-command' -if that history list is empty)." +in the grep command history (or into `grep-command' if that history +list is empty)." (interactive (progn (grep-compute-defaults) @@ -736,8 +747,9 @@ before it is executed. With two \\[universal-argument] prefixes, directly edit and run `grep-command'. Collect output in a buffer. While grep runs asynchronously, you -can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] -in the grep output buffer, to go to the lines where grep found matches. +can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \ +in the grep output buffer, +to go to the lines where grep found matches. This command shares argument histories with \\[rgrep] and \\[grep]." (interactive @@ -797,8 +809,9 @@ before it is executed. With two \\[universal-argument] prefixes, directly edit and run `grep-find-command'. Collect output in a buffer. While find runs asynchronously, you -can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] -in the grep output buffer, to go to the lines where grep found matches. +can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \ +in the grep output buffer, +to go to the lines where grep found matches. This command shares argument histories with \\[lgrep] and \\[grep-find]." (interactive diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index ce231f4c662..3c6736ac79b 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -318,6 +318,8 @@ Uses `gud-<MINOR-MODE>-directories' to find the source files." (setq directories (cdr directories))) result))) +(declare-function gdb-create-define-alist "gdb-ui" ()) + (defun gud-find-file (file) ;; Don't get confused by double slashes in the name that comes from GDB. (while (string-match "//+" file) @@ -709,6 +711,9 @@ The option \"--fullname\" must be included in this value." (defvar gud-filter-pending-text nil "Non-nil means this is text that has been saved for later in `gud-filter'.") +;; If in gdba mode, gdb-ui is loaded. +(declare-function gdb-restore-windows "gdb-ui" ()) + ;; The old gdb command (text command mode). The new one is in gdb-ui.el. ;;;###autoload (defun gud-gdb (command-line) @@ -2597,6 +2602,8 @@ It is saved for when this flag is not set.") (defvar gud-overlay-arrow-position nil) (add-to-list 'overlay-arrow-variable-list 'gud-overlay-arrow-position) +(declare-function gdb-reset "gdb-ui" ()) + (defun gud-sentinel (proc msg) (cond ((null (buffer-name (process-buffer proc))) ;; buffer killed @@ -2666,6 +2673,11 @@ Obeying it means displaying in another window the specified file and line." (setq gud-last-last-frame gud-last-frame gud-last-frame nil))) +(declare-function global-hl-line-highlight "hl-line" ()) +(declare-function hl-line-highlight "hl-line" ()) +(declare-function gdb-display-source-buffer "gdb-ui" (buffer)) +(declare-function gdb-display-buffer "gdb-ui" (buf dedicated &optional size)) + ;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen ;; and that its line LINE is visible. ;; Put the overlay-arrow on the line LINE in that buffer. @@ -2998,6 +3010,12 @@ Link exprs of the form: (t nil))) (t nil)))) + +(declare-function c-langelem-sym "cc-defs" (langelem)) +(declare-function c-langelem-pos "cc-defs" (langelem)) +(declare-function syntax-symbol "gud" (x)) +(declare-function syntax-point "gud" (x)) + (defun gud-find-class (f line) "Find fully qualified class in file F at line LINE. This function uses the `gud-jdb-classpath' (and optional @@ -3383,6 +3401,8 @@ With arg, dereference expr if ARG is positive, otherwise do not derereference." ((xdb pdb) (concat "p " expr)) (sdb (concat expr "/")))) +(declare-function gdb-enqueue-input "gdb-ui" (item)) + (defun gud-tooltip-tips (event) "Show tip for identifier or selection under the mouse. The mouse must either point at an identifier or inside a selected diff --git a/lisp/progmodes/idlw-complete-structtag.el b/lisp/progmodes/idlw-complete-structtag.el index d005c6de63e..cfd9834abca 100644 --- a/lisp/progmodes/idlw-complete-structtag.el +++ b/lisp/progmodes/idlw-complete-structtag.el @@ -91,6 +91,8 @@ (require 'idlwave) +(declare-function idlwave-shell-buffer "idlw-shell") + ;; Some variables to identify the previously used structure (defvar idlwave-current-tags-var nil) (defvar idlwave-current-tags-buffer nil) @@ -101,6 +103,7 @@ (defvar idlwave-sint-structtags nil) ;; Create the sintern type for structure talks +(declare-function idlwave-sintern-structtag "idlw-complete-structtag" t t) (idlwave-new-sintern-type 'structtag) ;; Hook the plugin into idlwave diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 2269e179357..69f24686e82 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -42,13 +42,10 @@ ;;; Code: -(defvar idlwave-help-browse-url-available nil +(defvar idlwave-help-browse-url-available t "Whether browse-url is available") -(setq idlwave-help-browse-url-available - (condition-case nil - (require 'browse-url) - (error nil))) +(require 'browse-url) (defgroup idlwave-online-help nil "Online Help options for IDLWAVE mode." @@ -258,6 +255,39 @@ support." (defvar idlwave-help-def-pos) (defvar idlwave-help-args) (defvar idlwave-help-in-header) +(declare-function idlwave-prepare-structure-tag-completion "idlw-complete-structtag") +(declare-function idlwave-all-method-classes "idlwave") +(declare-function idlwave-all-method-keyword-classes "idlwave") +(declare-function idlwave-beginning-of-statement "idlwave") +(declare-function idlwave-best-rinfo-assoc "idlwave") +(declare-function idlwave-class-found-in "idlwave") +(declare-function idlwave-class-or-superclass-with-tag "idlwave") +(declare-function idlwave-completing-read "idlwave") +(declare-function idlwave-current-routine "idlwave") +(declare-function idlwave-downcase-safe "idlwave") +(declare-function idlwave-entry-find-keyword "idlwave") +(declare-function idlwave-expand-keyword "idlwave") +(declare-function idlwave-find-class-definition "idlwave") +(declare-function idlwave-find-inherited-class "idlwave") +(declare-function idlwave-find-struct-tag "idlwave") +(declare-function idlwave-get-buffer-visiting "idlwave") +(declare-function idlwave-in-quote "idlwave") +(declare-function idlwave-make-full-name "idlwave") +(declare-function idlwave-members-only "idlwave") +(declare-function idlwave-popup-select "idlwave") +(declare-function idlwave-routine-source-file "idlwave") +(declare-function idlwave-routines "idlwave") +(declare-function idlwave-sintern-class "idlwave") +(declare-function idlwave-sintern-keyword "idlwave") +(declare-function idlwave-sintern-method "idlwave") +(declare-function idlwave-sintern-routine-or-method "idlwave") +(declare-function idlwave-sintern-sysvar "idlwave" t t);idlwave-new-sintern-type +(declare-function idlwave-sintern-sysvartag "idlwave" t t) +(declare-function idlwave-substitute-link-target "idlwave") +(declare-function idlwave-sys-dir "idlwave") +(declare-function idlwave-this-word "idlwave") +(declare-function idlwave-what-module-find-class "idlwave") +(declare-function idlwave-where "idlwave") (defun idlwave-help-mode () "Major mode for displaying IDL Help. diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index abe5cfe6489..9648494adc4 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -182,6 +182,13 @@ (defmacro defcustom (var value doc &rest args) `(defvar ,var ,value ,doc)))) +(declare-function idlwave-shell-get-path-info "idlw-shell") +(declare-function idlwave-shell-temp-file "idlw-shell") +(declare-function idlwave-shell-is-running "idlw-shell") +(declare-function widget-value "wid-edit" (widget)) +(declare-function comint-dynamic-complete-filename "comint" ()) +(declare-function Info-goto-node "info" (nodename &optional fork)) + (defgroup idlwave nil "Major mode for editing IDL .pro files." :tag "IDLWAVE" @@ -7599,6 +7606,7 @@ property indicating the link is added." (defvar idlwave-current-class-tags nil) (defvar idlwave-current-native-class-tags nil) (defvar idlwave-sint-class-tags nil) +(declare-function idlwave-sintern-class-tag "idlwave" t t) (idlwave-new-sintern-type 'class-tag) (add-to-list 'idlwave-complete-special 'idlwave-complete-class-structure-tag) (add-hook 'idlwave-update-rinfo-hook 'idlwave-class-tag-reset) @@ -7657,6 +7665,8 @@ property indicating the link is added." (defvar idlwave-sint-sysvars nil) (defvar idlwave-sint-sysvartags nil) +(declare-function idlwave-sintern-sysvar "idlwave" t t) +(declare-function idlwave-sintern-sysvartag "idlwave" t t) (idlwave-new-sintern-type 'sysvar) (idlwave-new-sintern-type 'sysvartag) (add-to-list 'idlwave-complete-special 'idlwave-complete-sysvar-or-tag) diff --git a/lisp/progmodes/octave-mod.el b/lisp/progmodes/octave-mod.el index a0d33f56ee4..e8246ddb816 100644 --- a/lisp/progmodes/octave-mod.el +++ b/lisp/progmodes/octave-mod.el @@ -52,6 +52,8 @@ (defvar inferior-octave-output-string nil) (defvar inferior-octave-receive-in-progress nil) +(declare-function inferior-octave-send-list-and-digest "octave-inf" (list)) + (defconst octave-maintainer-address "Kurt Hornik <Kurt.Hornik@wu-wien.ac.at>, bug-gnu-emacs@gnu.org" "Current maintainer of the Emacs Octave package.") diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index bb71491da2d..af456f98284 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -266,7 +266,9 @@ The expansion is entirely correct because it uses the C preprocessor." ;; format statements ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 '(7))) ;; Funny things in sub arg specifications like `sub myfunc ($$)' - ("\\<sub\\s-+\\S-+\\s-*(\\([^)]+\\))" 1 '(1)) + ;; Be careful not to match "sub { (...) ... }". + ("\\<sub[[:space:]]+[^{}[:punct:][:space:]]+[[:space:]]*(\\([^)]+\\))" + 1 '(1)) ;; Regexp and funny quotes. ("\\(?:[?:.,;=!~({[]\\|\\(^\\)\\)[ \t\n]*\\(/\\)" (2 (if (and (match-end 1) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 3583f546754..dd3503f16b0 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -240,6 +240,11 @@ rigidly along with this one (not yet)." (defvar inferior-prolog-mode-syntax-table prolog-mode-syntax-table) (defvar inferior-prolog-mode-abbrev-table prolog-mode-abbrev-table) +(declare-function comint-mode "comint") +(declare-function comint-send-string "comint" (process string)) +(declare-function comint-send-region "comint" (process start end)) +(declare-function comint-send-eof "comint" ()) + (define-derived-mode inferior-prolog-mode comint-mode "Inferior Prolog" "Major mode for interacting with an inferior Prolog process. diff --git a/lisp/progmodes/ps-mode.el b/lisp/progmodes/ps-mode.el index c131575f57c..6327a68302b 100644 --- a/lisp/progmodes/ps-mode.el +++ b/lisp/progmodes/ps-mode.el @@ -480,6 +480,9 @@ If nil, the following are tried in turn, until success: (setq i (1+ i))))) + +(declare-function doc-view-minor-mode "doc-view") + ;; PostScript mode. ;;;###autoload diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index f54b7c9f928..66779acb103 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -65,7 +65,6 @@ ;;; Code: (eval-when-compile - (require 'cl) (require 'compile) (require 'comint) (require 'hippie-exp)) @@ -1224,6 +1223,9 @@ local value.") ;; (modify-syntax-entry ?\" "." st) st)) +;; Autoloaded. +(declare-function compilation-shell-minor-mode "compile" (&optional arg)) + ;; Fixme: This should inherit some stuff from `python-mode', but I'm ;; not sure how much: at least some keybindings, like C-c C-f; ;; syntax?; font-locking, e.g. for triple-quoted strings? @@ -1656,6 +1658,8 @@ instance. Assumes an inferior Python is running." ;;;; Info-look functionality. +(declare-function info-lookup-maybe-add-help "info-look" (&rest arg)) + (defun python-after-info-look () "Set up info-look for Python. Used with `eval-after-load'." diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index e9d9247d7cb..cd08fea2910 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -1524,6 +1524,8 @@ with your script for an edit-interpret-debug cycle." skeleton-filter-function 'sh-feature skeleton-newline-indent-rigidly t sh-indent-supported-here nil) + (set (make-local-variable 'defun-prompt-regexp) + (concat "^\\(function[ \t]\\|[[:alnum:]]+[ \t]+()[ \t]+\\)")) (set (make-local-variable 'parse-sexp-ignore-comments) t) ;; Parse or insert magic number for exec, and set all variables depending ;; on the shell thus determined. diff --git a/lisp/replace.el b/lisp/replace.el index 7876f9bb47c..34fdd5fe3df 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -372,11 +372,9 @@ using `search-forward-regexp' and `replace-match' is preferred." "22.1") (defun map-query-replace-regexp (regexp to-strings &optional n start end) "Replace some matches for REGEXP with various strings, in rotation. -The second argument TO-STRINGS contains the replacement strings, -separated by spaces. Third arg DELIMITED (prefix arg if interactive), -if non-nil, means replace only matches surrounded by word boundaries. -This command works like `query-replace-regexp' except that each -successive replacement uses the next successive replacement string, +The second argument TO-STRINGS contains the replacement strings, separated +by spaces. This command works like `query-replace-regexp' except that +each successive replacement uses the next successive replacement string, wrapping around from the last such string to the first. In Transient Mark mode, if the mark is active, operate on the contents @@ -533,9 +531,20 @@ which will run faster and will not set the mark or print anything." "Read arguments for `keep-lines' and friends. Prompt for a regexp with PROMPT. Value is a list, (REGEXP)." - (list (read-from-minibuffer prompt nil nil nil - 'regexp-history nil t) - nil nil t)) + (let* ((default (list + (regexp-quote + (or (funcall (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default)) + "")) + (car regexp-search-ring) + (regexp-quote (or (car search-ring) "")) + (car (symbol-value + query-replace-from-history-variable)))) + (default (delete-dups (delq nil (delete "" default))))) + (list (read-from-minibuffer prompt nil nil nil + 'regexp-history default t) + nil nil t))) (defun keep-lines (regexp &optional rstart rend interactive) "Delete all lines except those containing matches for REGEXP. @@ -725,6 +734,35 @@ a previously found match." (define-key map "q" 'quit-window) (define-key map "z" 'kill-this-buffer) (define-key map "\C-c\C-f" 'next-error-follow-minor-mode) + (define-key map [menu-bar] (make-sparse-keymap)) + (define-key map [menu-bar occur] + (cons "Occur" map)) + (define-key map [next-error-follow-minor-mode] + (menu-bar-make-mm-toggle next-error-follow-minor-mode + "Auto Occurrence Display" + "Display another occurrence when moving the cursor")) + (define-key map [separator-1] '("--")) + (define-key map [kill-this-buffer] + '("Kill occur buffer" . kill-this-buffer)) + (define-key map [quit-window] + '("Quit occur window" . quit-window)) + (define-key map [revert-buffer] + '("Revert occur buffer" . revert-buffer)) + (define-key map [clone-buffer] + '("Clone occur buffer" . clone-buffer)) + (define-key map [occur-rename-buffer] + '("Rename occur buffer" . occur-rename-buffer)) + (define-key map [separator-2] '("--")) + (define-key map [occur-mode-goto-occurrence-other-window] + '("Go To Occurrence Other Window" . occur-mode-goto-occurrence-other-window)) + (define-key map [occur-mode-goto-occurrence] + '("Go To Occurrence" . occur-mode-goto-occurrence)) + (define-key map [occur-mode-display-occurrence] + '("Display Occurrence" . occur-mode-display-occurrence)) + (define-key map [occur-next] + '("Move to next match" . occur-next)) + (define-key map [occur-prev] + '("Move to previous match" . occur-prev)) map) "Keymap for `occur-mode'.") @@ -938,23 +976,29 @@ which means to discard all text properties." (nreverse result)))) (defun occur-read-primary-args () - (list (let* ((default (car regexp-history)) - (input - (read-from-minibuffer - (if default - (format "List lines matching regexp (default %s): " - (query-replace-descr default)) - "List lines matching regexp: ") - nil - nil - nil - 'regexp-history - default))) - (if (equal input "") - default - input)) - (when current-prefix-arg - (prefix-numeric-value current-prefix-arg)))) + (let* ((default + (list (and transient-mark-mode mark-active + (regexp-quote + (buffer-substring-no-properties + (region-beginning) (region-end)))) + (regexp-quote + (or (funcall + (or find-tag-default-function + (get major-mode 'find-tag-default-function) + 'find-tag-default)) + "")) + (car regexp-search-ring) + (regexp-quote (or (car search-ring) "")) + (car (symbol-value + query-replace-from-history-variable)))) + (default (delete-dups (delq nil (delete "" default)))) + (input + (read-from-minibuffer + "List lines matching regexp: " + nil nil nil 'regexp-history default))) + (list input + (when current-prefix-arg + (prefix-numeric-value current-prefix-arg))))) (defun occur-rename-buffer (&optional unique-p interactive-p) "Rename the current *Occur* buffer to *Occur: original-buffer-name*. diff --git a/lisp/reposition.el b/lisp/reposition.el index 3a5f24cbe8f..6ebbe57840d 100644 --- a/lisp/reposition.el +++ b/lisp/reposition.el @@ -171,8 +171,6 @@ first comment line visible (if point is in a comment)." ;;(repos-debug-macro "4") )))) -;;;###autoload (define-key esc-map "\C-l" 'reposition-window) - ;;; Auxiliary functions ;; Return number of screen lines between START and END. diff --git a/lisp/saveplace.el b/lisp/saveplace.el index b6f3a76ff23..df2deb6c14c 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -205,13 +205,15 @@ may have changed\) back to `save-place-alist'." (setq save-place-alist (cdr save-place-alist))))) (defun save-place-alist-to-file () - (let ((file (expand-file-name save-place-file))) + (let ((file (expand-file-name save-place-file)) + (coding-system-for-write 'utf-8)) (save-excursion - (message "Saving places to %s..." file) (set-buffer (get-buffer-create " *Saved Places*")) (delete-region (point-min) (point-max)) (when save-place-forget-unreadable-files (save-place-forget-unreadable-files)) + (insert (format ";;; -*- coding: %s -*-\n" + (symbol-name coding-system-for-write))) (let ((print-length nil) (print-level nil)) (print save-place-alist (current-buffer))) @@ -224,10 +226,9 @@ may have changed\) back to `save-place-alist'." t)))) (condition-case nil ;; Don't use write-file; we don't want this buffer to visit it. - (write-region (point-min) (point-max) file) - (file-error (message "Can't write %s" file))) - (kill-buffer (current-buffer)) - (message "Saving places to %s...done" file))))) + (write-region (point-min) (point-max) file) + (file-error (message "Saving places: can't write %s" file))) + (kill-buffer (current-buffer)))))) (defun load-save-place-alist-from-file () (if (not save-place-loaded) @@ -238,7 +239,6 @@ may have changed\) back to `save-place-alist'." ;; load it if it exists: (if (file-readable-p file) (save-excursion - (message "Loading places from %s..." file) ;; don't want to use find-file because we have been ;; adding hooks to it. (set-buffer (get-buffer-create " *Saved Places*")) @@ -266,8 +266,7 @@ may have changed\) back to `save-place-alist'." (setq count (1+ count))) (setq s (cdr s)))))) - (kill-buffer (current-buffer)) - (message "Loading places from %s...done" file))) + (kill-buffer (current-buffer)))) nil)))) (defun save-places-to-alist () diff --git a/lisp/select.el b/lisp/select.el index 14e53f75daa..35c103d1c15 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -166,6 +166,8 @@ prefix argument, it uses the text of the region as the selection value ." ;;; Cut Buffer support +(declare-function x-get-cut-buffer-internal "xselect.c") + (defun x-get-cut-buffer (&optional which-one) "Returns the value of one of the 8 X server cut-buffers. Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0. @@ -177,6 +179,9 @@ Cut buffers are considered obsolete; you should use selections instead." which-one) 'CUT_BUFFER0))) +(declare-function x-rotate-cut-buffers-internal "xselect.c") +(declare-function x-store-cut-buffer-internal "xselect.c") + (defun x-set-cut-buffer (string &optional push) "Store STRING into the X server's primary cut buffer. If PUSH is non-nil, also rotate the cut buffers: diff --git a/lisp/server.el b/lisp/server.el index 329010cc950..e6477b92d6f 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -811,17 +811,18 @@ The following commands are accepted by the client: tty-type ;string. (files nil) (lineno 1) - (columnno 0)) + (columnno 0) + command-line-args-left + arg) ;; Remove this line from STRING. (setq string (substring string (match-end 0))) - (while (string-match " *[^ ]* " request) - (let ((arg (substring request (match-beginning 0) - (1- (match-end 0))))) - (setq request (substring request (match-end 0))) + (setq command-line-args-left + (mapcar 'server-unquote-arg (split-string request " " t))) + (while (setq arg (pop command-line-args-left)) (cond ;; -version CLIENT-VERSION: obsolete at birth. - ((and (equal "-version" arg) (string-match "[^ ]+ " request)) - (setq request (substring request (match-end 0)))) + ((and (equal "-version" arg) command-line-args-left) + (pop command-line-args-left)) ;; -nowait: Emacsclient won't wait for a result. ((equal "-nowait" arg) (setq nowait t)) @@ -831,10 +832,8 @@ The following commands are accepted by the client: ;; -display DISPLAY: ;; Open X frames on the given display instead of the default. - ((and (equal "-display" arg) - (string-match "\\([^ ]*\\) " request)) - (setq display (match-string 1 request)) - (setq request (substring request (match-end 0)))) + ((and (equal "-display" arg) command-line-args-left) + (setq display (pop command-line-args-left))) ;; -window-system: Open a new X frame. ((equal "-window-system" arg) @@ -863,33 +862,32 @@ The following commands are accepted by the client: ;; -ignore COMMENT: Noop; useful for debugging emacsclient. ;; (The given comment appears in the server log.) - ((and (equal "-ignore" arg) (string-match "[^ ]* " request)) - (setq dontkill t - request (substring request (match-end 0)))) + ((and (equal "-ignore" arg) command-line-args-left + (setq dontkill t) + (pop command-line-args-left))) ;; -tty DEVICE-NAME TYPE: Open a new tty frame at the client. ((and (equal "-tty" arg) - (string-match "\\([^ ]*\\) \\([^ ]*\\) " request)) - (setq tty-name (match-string 1 request)) - (setq tty-type (match-string 2 request)) - (setq dontkill t) - (setq request (substring request (match-end 0)))) + (cdr command-line-args-left)) + (setq tty-name (pop command-line-args-left) + tty-type (pop command-line-args-left) + dontkill t)) ;; -position LINE[:COLUMN]: Set point to the given ;; position in the next file. ((and (equal "-position" arg) - (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)? " - request)) - (setq lineno (string-to-number (match-string 1 request)) + command-line-args-left + (string-match "\\+\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" + (car command-line-args-left))) + (setq arg (pop command-line-args-left)) + (setq lineno (string-to-number (match-string 1 arg)) columnno (if (null (match-end 2)) 0 - (string-to-number (match-string 2 request))) - request (substring request (match-end 0)))) + (string-to-number (match-string 2 arg))))) ;; -file FILENAME: Load the given file. ((and (equal "-file" arg) - (string-match "\\([^ ]+\\) " request)) - (let ((file (server-unquote-arg (match-string 1 request)))) - (setq request (substring request (match-end 0))) + command-line-args-left) + (let ((file (pop command-line-args-left))) (if coding-system (setq file (decode-coding-string file coding-system))) (setq file (command-line-normalize-file-name file)) @@ -901,10 +899,8 @@ The following commands are accepted by the client: ;; -eval EXPR: Evaluate a Lisp expression. ((and (equal "-eval" arg) - (string-match "\\([^ ]+\\) " request)) - (lexical-let ((expr (server-unquote-arg - (match-string 1 request)))) - (setq request (substring request (match-end 0))) + command-line-args-left) + (lexical-let ((expr (pop command-line-args-left))) (if coding-system (setq expr (decode-coding-string expr coding-system))) (push (lambda () (server-eval-and-print expr proc)) @@ -913,23 +909,21 @@ The following commands are accepted by the client: columnno 0))) ;; -env NAME=VALUE: An environment variable. - ((and (equal "-env" arg) (string-match "\\([^ ]+\\) " request)) - (let ((var (server-unquote-arg (match-string 1 request)))) + ((and (equal "-env" arg) command-line-args-left) + (let ((var (pop command-line-args-left))) ;; XXX Variables should be encoded as in getenv/setenv. - (setq request (substring request (match-end 0))) (process-put proc 'env (cons var (process-get proc 'env))))) ;; -dir DIRNAME: The cwd of the emacsclient process. - ((and (equal "-dir" arg) (string-match "\\([^ ]+\\) " request)) - (setq dir (server-unquote-arg (match-string 1 request))) - (setq request (substring request (match-end 0))) + ((and (equal "-dir" arg) command-line-args-left) + (setq dir (pop command-line-args-left)) (if coding-system (setq dir (decode-coding-string dir coding-system))) (setq dir (command-line-normalize-file-name dir))) ;; Unknown command. - (t (error "Unknown command: %s" arg))))) + (t (error "Unknown command: %s" arg)))) (setq frame (case tty-name diff --git a/lisp/gnus/sha1.el b/lisp/sha1.el index 146aa6374a0..0026866c187 100644 --- a/lisp/gnus/sha1.el +++ b/lisp/sha1.el @@ -6,21 +6,21 @@ ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: SHA1, FIPS 180-1 -;; This file is part of FLIM (Faithful Library about Internet Message). +;; This file is part of GNU Emacs. -;; 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 3, or -;; (at your option) any later version. +;; GNU Emacs 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 3, or (at your option) +;; any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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. ;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: diff --git a/lisp/simple.el b/lisp/simple.el index f6a8818e5a9..bdf55d859b2 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -1633,7 +1633,7 @@ as an argument limits undo to changes within the current region." (delete-auto-save-file-if-necessary recent-save)) ;; Display a message announcing success. (if message - (message message)))) + (message "%s" message)))) (defun buffer-disable-undo (&optional buffer) "Make BUFFER stop keeping undo information. @@ -5646,7 +5646,7 @@ front of the list of recently selected ones." ;;; Handling of Backspace and Delete keys. (defcustom normal-erase-is-backspace 'maybe - "Set the default behaviour of the Delete and Backspace keys. + "Set the default behavior of the Delete and Backspace keys. If set to t, Delete key deletes forward and Backspace key deletes backward. @@ -5654,7 +5654,7 @@ backward. If set to nil, both Delete and Backspace keys delete backward. If set to 'maybe (which is the default), Emacs automatically -selects a behaviour. On window systems, the behaviour depends on +selects a behavior. On window systems, the behavior depends on the keyboard used. If the keyboard has both a Backspace key and a Delete key, and both are mapped to their usual meanings, the option's default value is set to t, so that Backspace can be used diff --git a/lisp/smerge-mode.el b/lisp/smerge-mode.el index 18ca1a34181..dcbb97bd79c 100644 --- a/lisp/smerge-mode.el +++ b/lisp/smerge-mode.el @@ -905,6 +905,7 @@ replace chars to try and eliminate some spurious differences." (defvar ediff-buffer-C) (defvar ediff-ancestor-buffer) (defvar ediff-quit-hook) +(declare-function ediff-cleanup-mess "ediff-util" nil) ;;;###autoload (defun smerge-ediff (&optional name-mine name-other name-base) diff --git a/lisp/subr.el b/lisp/subr.el index 16cb8913559..d16d4d26693 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -36,6 +36,42 @@ Each element of this list holds the arguments to one call to `defcustom'.") (setq custom-declare-variable-list (cons arguments custom-declare-variable-list))) +(defmacro declare-function (fn file &optional arglist fileonly) + "Tell the byte-compiler that function FN is defined, in FILE. +Optional ARGLIST is the argument list used by the function. The +FILE argument is not used by the byte-compiler, but by the +`check-declare' package, which checks that FILE contains a +definition for FN. ARGLIST is used by both the byte-compiler and +`check-declare' to check for consistency. + +FILE can be either a Lisp file (in which case the \".el\" +extension is optional), or a C file. C files are expanded +relative to the Emacs \"src/\" directory. Lisp files are +searched for using `locate-library', and if that fails they are +expanded relative to the location of the file containing the +declaration. A FILE with an \"ext:\" prefix is an external file. +`check-declare' will check such files if they are found, and skip +them without error if they are not. + +FILEONLY non-nil means that `check-declare' will only check that +FILE exists, not that it defines FN. This is intended for +function-definitions that `check-declare' does not recognize, e.g. +`defstruct'. + +To specify a value for FILEONLY without passing an argument list, +set ARGLIST to `t'. This is necessary because `nil' means an +empty argument list, rather than an unspecified one. + +Note that for the purposes of `check-declare', this statement +must be the first non-whitespace on a line, and everything up to +the end of FILE must be all on the same line. For example: + +\(declare-function c-end-of-defun \"progmodes/cc-cmds.el\" + \(&optional arg)) + +For more information, see Info node `elisp(Declaring Functions)'." + ;; Does nothing - byte-compile-declare-function does the work. + nil) ;;;; Basic Lisp macros. @@ -723,7 +759,9 @@ even when EVENT actually has modifiers." (if (listp type) (setq type (car type))) (if (symbolp type) - (cdr (get type 'event-symbol-elements)) + ;; Don't read event-symbol-elements directly since we're not + ;; sure the symbol has already been parsed. + (cdr (internal-event-symbol-parse-modifiers type)) (let ((list nil) (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ ?\H-\^@ ?\s-\^@ ?\A-\^@))))) @@ -858,7 +896,8 @@ and `event-end' functions." (x (/ (car pair) (frame-char-width frame))) (y (/ (cdr pair) (+ (frame-char-height frame) (or (frame-parameter frame 'line-spacing) - default-line-spacing + ;; FIXME: Why the `default'? + (default-value 'line-spacing) 0))))) (cons x y)))))) @@ -945,7 +984,7 @@ is converted into a string by expressing it in decimal." (make-obsolete 'focus-frame "it does nothing." "22.1") (defalias 'unfocus-frame 'ignore "") (make-obsolete 'unfocus-frame "it does nothing." "22.1") -(make-obsolete 'make-variable-frame-local "use a frame-parameter instead" "22.2") +(make-obsolete 'make-variable-frame-local "use a frame-parameter instead." "22.2") ;;;; Obsolescence declarations for variables, and aliases. @@ -1537,6 +1576,23 @@ FILE should be the name of a library, with no directory name." ;;;; Process stuff. +(defun process-lines (program &rest args) + "Execute PROGRAM with ARGS, returning its output as a list of lines. +Signal an error if the program returns with a non-zero exit status." + (with-temp-buffer + (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (unless (eq status 0) + (error "%s exited with status %s" program status)) + (goto-char (point-min)) + (let (lines) + (while (not (eobp)) + (setq lines (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + lines)) + (forward-line 1)) + (nreverse lines))))) + ;; open-network-stream is a wrapper around make-network-process. (when (featurep 'make-network-process) @@ -2099,6 +2155,8 @@ a system-dependent default device name is used." (play-sound-internal sound) (error "This Emacs binary lacks sound support"))) +(declare-function w32-shell-dos-semantics "w32-fns" nil) + (defun shell-quote-argument (argument) "Quote an argument for passing as argument to an inferior shell." (if (or (eq system-type 'ms-dos) diff --git a/lisp/term/mac-win.el b/lisp/term/mac-win.el index e81f71c582f..3c648b9e6b3 100644 --- a/lisp/term/mac-win.el +++ b/lisp/term/mac-win.el @@ -84,6 +84,14 @@ (defvar mac-font-panel-mode) (defvar mac-ts-active-input-overlay) (defvar x-invocation-args) +(declare-function mac-code-convert-string "mac.c") +(declare-function mac-coerce-ae-data "mac.c") +(declare-function mac-resume-apple-event "macselect.c") +;; Suppress warning when compiling on non-Mac. +(declare-function mac-font-panel-mode "mac-win.el") +(declare-function mac-atsu-font-face-attributes "macfns.c") +(declare-function mac-ae-set-reply-parameter "macselect.c") +(declare-function mac-clear-font-name-table "macfns.c") (defvar x-command-line-resources nil) @@ -1058,28 +1066,31 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") ;;;; Function keys -(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame - global-map) - (defun x-setup-function-keys (frame) "Setup Function Keys for mac." -;; Map certain keypad keys into ASCII characters -;; that people usually expect. -(define-key local-function-key-map [backspace] [?\d]) -(define-key local-function-key-map [delete] [?\d]) -(define-key local-function-key-map [tab] [?\t]) -(define-key local-function-key-map [linefeed] [?\n]) -(define-key local-function-key-map [clear] [?\C-l]) -(define-key local-function-key-map [return] [?\C-m]) -(define-key local-function-key-map [escape] [?\e]) -(define-key local-function-key-map [M-backspace] [?\M-\d]) -(define-key local-function-key-map [M-delete] [?\M-\d]) -(define-key local-function-key-map [M-tab] [?\M-\t]) -(define-key local-function-key-map [M-linefeed] [?\M-\n]) -(define-key local-function-key-map [M-clear] [?\M-\C-l]) -(define-key local-function-key-map [M-return] [?\M-\C-m]) -(define-key local-function-key-map [M-escape] [?\M-\e]) -) + ;; Don't do this twice on the same display, or it would break + ;; normal-erase-is-backspace-mode. + (unless (terminal-parameter frame 'x-setup-function-keys) + (with-selected-frame frame + ;; Map certain keypad keys into ASCII characters + ;; that people usually expect. + (define-key local-function-key-map [backspace] [?\d]) + (define-key local-function-key-map [delete] [?\d]) + (define-key local-function-key-map [tab] [?\t]) + (define-key local-function-key-map [linefeed] [?\n]) + (define-key local-function-key-map [clear] [?\C-l]) + (define-key local-function-key-map [return] [?\C-m]) + (define-key local-function-key-map [escape] [?\e]) + (define-key local-function-key-map [M-backspace] [?\M-\d]) + (define-key local-function-key-map [M-delete] [?\M-\d]) + (define-key local-function-key-map [M-tab] [?\M-\t]) + (define-key local-function-key-map [M-linefeed] [?\M-\n]) + (define-key local-function-key-map [M-clear] [?\M-\C-l]) + (define-key local-function-key-map [M-return] [?\M-\C-m]) + (define-key local-function-key-map [M-escape] [?\M-\e]) + (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame + local-function-key-map global-map)) + (set-terminal-parameter frame 'x-setup-function-keys t))) ;; These tell read-char how to convert ;; these special chars to ASCII. @@ -1811,6 +1822,9 @@ if possible. If there's no such frame, a new frame is created." ;; Reaches here if the user has canceled the quit. (mac-resume-apple-event ae -128)))) ; userCanceledErr +;; url-generic-parse-url is autoloaded from url-parse. +(declare-function url-type "url-parse" t t) ; defstruct + (defun mac-ae-get-url (event) "Open the URL specified by the Apple event EVENT. Currently the `mailto' scheme is supported." diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index ecbda7d9c1e..2ddb4e40433 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -29,6 +29,10 @@ (load "term/internal" nil t) +(declare-function msdos-remember-default-colors "msdos.c") +(declare-function w16-set-clipboard-data "w16select.c") +(declare-function w16-get-clipboard-data "w16select.c") + ;;; This is copied from etc/rgb.txt, except that some values were changed ;;; a bit to make them consistent with DOS console colors, and the RGB ;;; values were scaled up to 16 bits, as `tty-define-color' requires. diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el index 70323e3155b..5622efa022d 100644 --- a/lisp/term/tty-colors.el +++ b/lisp/term/tty-colors.el @@ -63,7 +63,6 @@ ;;; Code: (defvar msdos-color-values) -(defvar w32-tty-standard-colors) ;; The following list is taken from rgb.txt distributed with X. ;; @@ -816,8 +815,6 @@ Value is the modified color alist for FRAME." "Register the default set of colors for a character terminal." (let* ((colors (cond ((eq window-system 'pc) msdos-color-values) - ((eq system-type 'windows-nt) - w32-tty-standard-colors) (t tty-standard-colors))) (color (car colors))) (while colors diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 688dd7deea8..bdaeaf1b52e 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -87,6 +87,10 @@ (defvar xlfd-regexp-registry-subnum) (defvar w32-color-map) ;; defined in w32fns.c +(declare-function w32-send-sys-command "w32fns.c") +(declare-function w32-select-font "w32fns.c") +(declare-function set-message-beep "w32console.c") + ;; Conditional on new-fontset so bootstrapping works on non-GUI compiles (if (fboundp 'new-fontset) (require 'fontset)) @@ -1053,17 +1057,6 @@ XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") If FRAME is nil or not given, use the selected frame." (interactive "i") (w32-send-sys-command ?\xf100 frame)) - -(defun x-setup-function-keys (frame) - "Setup Function Keys for w32." - (with-selected-frame frame - (define-key local-function-key-map [f10] 'menu-bar-open) - - (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame - local-function-key-map global-map) - - (define-key local-function-key-map [S-tab] [backtab])) - (set-terminal-parameter frame 'x-setup-function-keys t)) ;; W32 systems have different fonts than commonly found on X, so diff --git a/lisp/term/w32console.el b/lisp/term/w32console.el new file mode 100644 index 00000000000..f45d7e0ad7a --- /dev/null +++ b/lisp/term/w32console.el @@ -0,0 +1,65 @@ +;;; w32console.el -- Setup w32 console keys and colors. + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: FSF +;; Keywords: terminals + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3, or (at your option) +;; any later version. + +;; GNU Emacs 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. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Code: + +;; W32 uses different color indexes than standard: + +(defvar w32-tty-standard-colors + '(("black" 0 0 0 0) + ("blue" 1 0 0 52480) ; MediumBlue + ("green" 2 8704 35584 8704) ; ForestGreen + ("cyan" 3 0 52736 53504) ; DarkTurquoise + ("red" 4 45568 8704 8704) ; FireBrick + ("magenta" 5 35584 0 35584) ; DarkMagenta + ("brown" 6 40960 20992 11520) ; Sienna + ("lightgray" 7 48640 48640 48640) ; Gray + ("darkgray" 8 26112 26112 26112) ; Gray40 + ("lightblue" 9 0 0 65535) ; Blue + ("lightgreen" 10 0 65535 0) ; Green + ("lightcyan" 11 0 65535 65535) ; Cyan + ("lightred" 12 65535 0 0) ; Red + ("lightmagenta" 13 65535 0 65535) ; Magenta + ("yellow" 14 65535 65535 0) ; Yellow + ("white" 15 65535 65535 65535)) +"A list of VGA console colors, their indices and 16-bit RGB values.") + +(defun terminal-init-w32console () + "Terminal initialization function for w32 console." + ;; Share function key initialization with w32 gui frames + (x-setup-function-keys (selected-frame)) + (let* ((colors w32-tty-standard-colors) + (color (car colors))) + (tty-color-clear) + (while colors + (tty-color-define (car color) (cadr color) (cddr color)) + (setq colors (cdr colors) + color (car colors)))) + (clear-face-cache) + (tty-set-up-initial-frame-faces) + (run-hooks 'terminal-init-w32-hook)) + +;; arch-tag: 3195fd5e-ab86-4a46-b1dc-4f7a8c8deff3 diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index eb2e559a0d1..ffd2a98c6b0 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -2576,15 +2576,18 @@ If you don't want stock icons, set the variable to nil." (defun x-gtk-map-stock (file) "Map icon with file name FILE to a Gtk+ stock name, using `x-gtk-stock-map'." - (let* ((file-sans (file-name-sans-extension file)) - (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" file-sans) - (match-string 1 file-sans))) - (value)) - (mapc (lambda (elem) - (let ((assoc (if (symbolp elem) (symbol-value elem) elem))) - (or value (setq value (assoc-string (or key file-sans) assoc))))) - icon-map-list) - (and value (cdr value)))) + (if (stringp file) + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" file-sans) + (match-string 1 file-sans))) + (value)) + (mapc (lambda (elem) + (let ((assoc (if (symbolp elem) (symbol-value elem) elem))) + (or value (setq value (assoc-string (or key file-sans) + assoc))))) + icon-map-list) + (and value (cdr value))) + nil)) (provide 'x-win) diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 8660f75fa95..83af2156831 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -256,11 +256,9 @@ (defvar css-font-lock-defaults '(css-font-lock-keywords nil t)) -(unless (fboundp 'prog-mode) (defalias 'prog-mode 'fundamental-mode)) - ;;;###autoload (add-to-list 'auto-mode-alist '("\\.css\\'" . css-mode)) ;;;###autoload -(define-derived-mode css-mode prog-mode "CSS" +(define-derived-mode css-mode fundamental-mode "CSS" "Major mode to edit Cascading Style Sheets." (set (make-local-variable 'font-lock-defaults) css-font-lock-defaults) (set (make-local-variable 'comment-start) "/*") diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index 27c425de448..0516a4ab8a5 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -836,6 +836,10 @@ in the active region." (fill-region-as-paragraph beg end justify)))))) fill-pfx))) +(declare-function comment-search-forward "newcomment" (limit &optional noerror)) +(declare-function comment-string-strip "newcomment" (str beforep afterp)) + + (defun fill-comment-paragraph (&optional justify) "Fill current comment. If we're not in a comment, just return nil so that the caller diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 73e8ec49045..16265ae42d1 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -1531,29 +1531,42 @@ The buffer to mark them in is `flyspell-large-region-buffer'." (if flyspell-issue-message-flag (message "Checking region...")) (set-buffer curbuf) (ispell-check-version) - (let ((c (apply 'ispell-call-process-region beg - end - ispell-program-name - nil - buffer - nil - (if ispell-really-aspell "list" "-l") - (let (args) - ;; Local dictionary becomes the global dictionary in use. - (if ispell-local-dictionary - (setq ispell-dictionary ispell-local-dictionary)) - (setq args (ispell-get-ispell-args)) - (if ispell-dictionary ; use specified dictionary - (setq args - (append (list "-d" ispell-dictionary) args))) - (if ispell-personal-dictionary ; use specified pers dict - (setq args - (append args - (list "-p" - (expand-file-name - ispell-personal-dictionary))))) - (setq args (append args ispell-extra-args)) - args)))) + ;; Local dictionary becomes the global dictionary in use. + (setq ispell-current-dictionary + (or ispell-local-dictionary ispell-dictionary)) + (setq ispell-current-personal-dictionary + (or ispell-local-pdict ispell-personal-dictionary)) + (let ((args (ispell-get-ispell-args)) + (encoding (ispell-get-coding-system)) + c) + (if (and ispell-current-dictionary ; use specified dictionary + (not (member "-d" args))) ; only define if not overridden + (setq args + (append (list "-d" ispell-current-dictionary) args))) + (if ispell-current-personal-dictionary ; use specified pers dict + (setq args + (append args + (list "-p" + (expand-file-name + ispell-current-personal-dictionary))))) + (setq args (append args ispell-extra-args)) + (if (and ispell-really-aspell + ispell-aspell-supports-utf8) + (setq args + (append args + (list + (concat "--encoding=" + (symbol-name + encoding)))))) + (let ((process-coding-system-alist (list (cons "\\.*" encoding)))) + (setq c (apply 'ispell-call-process-region beg + end + ispell-program-name + nil + buffer + nil + (if ispell-really-aspell "list" "-l") + args))) (if (eq c 0) (progn (flyspell-process-localwords buffer) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 926e0debda1..163f436e53d 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -981,7 +981,7 @@ Assumes that value contains no whitespace." "[^[:alpha:]]" (regexp-opt otherchars) t ; We can't tell, so set this to t - (list "-d" dict-name "--encoding=utf-8") + (list "-d" dict-name) nil ; aspell doesn't support this ;; Here we specify the encoding to use while communicating with ;; aspell. This doesn't apply to command line arguments, so @@ -1161,12 +1161,13 @@ The variable `ispell-library-directory' defines the library location." (delete-menu-item '("Edit" "Spell")) ; in case already defined (add-menu '("Edit") "Spell" ispell-menu-xemacs)))))) -;;; Allow incrementing characters as integers in XEmacs 20 -(if (and (featurep 'xemacs) - (fboundp 'int-char)) - (fset 'ispell-int-char 'int-char) - ;; Emacs and XEmacs 19 or earlier - (fset 'ispell-int-char 'identity)) +(defalias 'ispell-int-char + ;; Allow incrementing characters as integers in XEmacs 20 + (if (and (featurep 'xemacs) + (fboundp 'int-char)) + 'int-char + ;; Emacs and XEmacs 19 or earlier + 'identity)) ;;; ********************************************************************** @@ -2480,6 +2481,13 @@ Keeps argument list for future ispell invocations for no async support." (append args (list "-p" (expand-file-name ispell-current-personal-dictionary))))) + (if (and ispell-really-aspell + ispell-aspell-supports-utf8) + (setq args + (append args + (list + (concat "--encoding=" + (symbol-name (ispell-get-coding-system))))))) (setq args (append args ispell-extra-args)) ;; Initially we don't know any buffer's local words. @@ -3503,9 +3511,9 @@ You can bind this to the key C-c i in GNUS or mail by adding to (cite-regexp ;Prefix of quoted text (cond ((functionp 'sc-cite-regexp) ; sc 3.0 - (concat "\\(" (sc-cite-regexp) "\\)" "\\|" - (with-no-warnings - (ispell-non-empty-string sc-reference-tag-string)))) + (with-no-warnings + (concat "\\(" (sc-cite-regexp) "\\)" "\\|" + (ispell-non-empty-string sc-reference-tag-string)))) ((boundp 'sc-cite-regexp) ; sc 2.3 (concat "\\(" sc-cite-regexp "\\)" "\\|" (with-no-warnings diff --git a/lisp/textmodes/org-export-latex.el b/lisp/textmodes/org-export-latex.el index b1b31b622d1..eef1c10e5b6 100644 --- a/lisp/textmodes/org-export-latex.el +++ b/lisp/textmodes/org-export-latex.el @@ -1077,9 +1077,8 @@ Valid parameters are (path (insert (format "\\href{%s}{%s}" path desc))) (t (insert "\\texttt{" desc "}"))))))) -(defun org-export-latex-cleaned-string +(defun org-export-latex-cleaned-string (&optional commentsp) ;; FIXME remove commentsp call in org.el and here - (&optional commentsp) "Clean stuff in the LaTeX export." ;; Preserve line breaks diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el index b555e6c1102..0535f679c40 100644 --- a/lisp/textmodes/org.el +++ b/lisp/textmodes/org.el @@ -3883,6 +3883,84 @@ If it is less than 8, the level-1 face gets re-used for level N+1 etc." :type 'number :group 'org-faces) +;;; Function declarations. +(declare-function add-to-diary-list "diary-lib" + (date string specifier &optional marker globcolor literal)) +(declare-function table--at-cell-p "table" (position &optional object at-column)) +(declare-function Info-find-node "info" (filename nodename &optional no-going-back)) +(declare-function Info-goto-node "info" (nodename &optional fork)) +(declare-function bbdb "ext:bbdb-com" (string elidep)) +(declare-function bbdb-company "ext:bbdb-com" (string elidep)) +(declare-function bbdb-current-record "ext:bbdb-com" (&optional planning-on-modifying)) +(declare-function bbdb-name "ext:bbdb-com" (string elidep)) +(declare-function bbdb-record-getprop "ext:bbdb" (record property)) +(declare-function bbdb-record-name "ext:bbdb" (record)) +(declare-function bibtex-beginning-of-entry "bibtex" ()) +(declare-function bibtex-generate-autokey "bibtex" ()) +(declare-function bibtex-parse-entry "bibtex" (&optional content)) +(declare-function bibtex-url "bibtex" (&optional pos no-browse)) +(declare-function calendar-astro-date-string "cal-julian" (&optional date)) +(declare-function calendar-bahai-date-string "cal-bahai" (&optional date)) +(declare-function calendar-check-holidays "holidays" (date)) +(declare-function calendar-chinese-date-string "cal-china" (&optional date)) +(declare-function calendar-coptic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-ethiopic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-forward-day "cal-move" (arg)) +(declare-function calendar-french-date-string "cal-french" (&optional date)) +(declare-function calendar-goto-date "cal-move" (date)) +(declare-function calendar-goto-today "cal-move" ()) +(declare-function calendar-hebrew-date-string "cal-hebrew" (&optional date)) +(declare-function calendar-islamic-date-string "cal-islam" (&optional date)) +(declare-function calendar-iso-date-string "cal-iso" (&optional date)) +(declare-function calendar-julian-date-string "cal-julian" (&optional date)) +(declare-function calendar-mayan-date-string "cal-mayan" (&optional date)) +(declare-function calendar-persian-date-string "cal-persia" (&optional date)) +(declare-function cdlatex-tab "ext:cdlatex" ()) +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(declare-function gnus-article-show-summary "gnus-art" ()) +(declare-function gnus-summary-last-subject "gnus-sum" ()) +(declare-function mh-display-msg "mh-show" (msg-num folder-name)) +(declare-function mh-find-path "mh-utils" ()) +(declare-function mh-get-header-field "mh-utils" (field)) +(declare-function mh-get-msg-num "mh-utils" (error-if-no-message)) +(declare-function mh-header-display "mh-show" ()) +(declare-function mh-index-previous-folder "mh-search" ()) +(declare-function mh-normalize-folder-name "mh-utils" (folder &optional empty-string-okay dont-remove-trailing-slash return-nil-if-folder-empty)) +(declare-function mh-search "mh-search" (folder search-regexp &optional redo-search-flag window-config)) +(declare-function mh-search-choose "mh-search" (&optional searcher)) +(declare-function mh-show "mh-show" (&optional message redisplay-flag)) +(declare-function mh-show-buffer-message-number "mh-comp" (&optional buffer)) +(declare-function mh-show-header-display "mh-show" t t) +(declare-function mh-show-msg "mh-show" (msg)) +(declare-function mh-show-show "mh-show" t t) +(declare-function mh-visit-folder "mh-folder" (folder &optional range index-data)) +(declare-function org-export-latex-cleaned-string "org-export-latex" (&optional commentsp)) +(declare-function parse-time-string "parse-time" (string)) +(declare-function remember "remember" (&optional initial)) +(declare-function remember-buffer-desc "remember" ()) +(declare-function rmail-narrow-to-non-pruned-header "rmail" ()) +(declare-function rmail-show-message "rmail" (&optional n no-summary)) +(declare-function rmail-what-message "rmail" ()) +(declare-function elmo-folder-exists-p "ext:elmo" (folder) t) +(declare-function elmo-message-entity-field "ext:elmo-msgdb" (entity field &optional type)) +(declare-function elmo-message-field "ext:elmo" (folder number field &optional type) t) +(declare-function vm-beginning-of-message "ext:vm-page" ()) +(declare-function vm-follow-summary-cursor "ext:vm-motion" ()) +(declare-function vm-get-header-contents "ext:vm-summary" (message header-name-regexp &optional clump-sep)) +(declare-function vm-isearch-narrow "ext:vm-search" ()) +(declare-function vm-isearch-update "ext:vm-search" ()) +(declare-function vm-select-folder-buffer "ext:vm-macro" ()) +(declare-function vm-su-message-id "ext:vm-summary" (m)) +(declare-function vm-su-subject "ext:vm-summary" (m)) +(declare-function vm-summarize "ext:vm-summary" (&optional display raise)) +(declare-function wl-folder-get-elmo-folder "ext:wl-folder" (entity &optional no-cache)) +(declare-function wl-summary-goto-folder-subr "ext:wl-summary" (&optional name scan-type other-window sticky interactive scoring force-exit)) +(declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary" (&optional id)) +(declare-function wl-summary-line-from "ext:wl-summary" ()) +(declare-function wl-summary-line-subject "ext:wl-summary" ()) +(declare-function wl-summary-message-number "ext:wl-summary" ()) +(declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg)) + ;;; Variables for pre-computed regular expressions, all buffer local (defvar org-drawer-regexp nil @@ -16838,7 +16916,7 @@ D may be an absolute day number, or a calendar-type list (month day year)." (defun org-calendar-holiday () "List of holidays, for Diary display in Org-mode." - (let ((hl (check-calendar-holidays date))) + (let ((hl (calendar-check-holidays date))) (if hl (mapconcat 'identity hl "; ")))) (defun org-diary-sexp-entry (sexp entry date) diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 201eeebb623..06ebeea9fa0 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -440,8 +440,8 @@ negative arg -N means kill forward to Nth end of paragraph." (end-of-paragraph-text)))))) (defun forward-sentence (&optional arg) - "Move forward to next `sentence-end'. With argument, repeat. -With negative argument, move backward repeatedly to `sentence-beginning'. + "Move forward to next end of sentence. With argument, repeat. +With negative argument, move backward repeatedly to start of sentence. The variable `sentence-end' is a regular expression that matches ends of sentences. Also, every paragraph boundary terminates sentences as well." diff --git a/lisp/textmodes/reftex-auc.el b/lisp/textmodes/reftex-auc.el index e49c408b6e5..e7d292f48bb 100644 --- a/lisp/textmodes/reftex-auc.el +++ b/lisp/textmodes/reftex-auc.el @@ -33,6 +33,18 @@ (require 'reftex) ;;; +(declare-function TeX-argument-insert "ext:tex" (name optional &optional prefix)) +(declare-function TeX-argument-prompt "ext:tex" (optional prompt default &optional complete)) +(declare-function multi-prompt "ext:multi-prompt" + (separator + unique prompt table + &optional mp-predicate require-match initial history)) +(declare-function LaTeX-add-index-entries "ext:tex" (&rest entries) t) +(declare-function LaTeX-add-labels "ext:tex" (&rest entries) t) +(declare-function LaTeX-bibitem-list "ext:tex" () t) +(declare-function LaTeX-index-entry-list "ext:tex" () t) +(declare-function LaTeX-label-list "ext:tex" () t) + (defun reftex-plug-flag (which) ;; Tell if a certain flag is set in reftex-plug-into-AUCTeX (or (eq t reftex-plug-into-AUCTeX) diff --git a/lisp/textmodes/reftex-dcr.el b/lisp/textmodes/reftex-dcr.el index cfee8b53c0b..86ad54a73fa 100644 --- a/lisp/textmodes/reftex-dcr.el +++ b/lisp/textmodes/reftex-dcr.el @@ -352,13 +352,15 @@ will display info in the echo area." (message "Automatic display of crossref information was turned on"))) (defun reftex-start-itimer-once () - (and reftex-mode + (and (featurep 'xemacs) reftex-mode (not (itimer-live-p reftex-auto-view-crossref-timer)) (setq reftex-auto-view-crossref-timer (start-itimer "RefTeX Idle Timer" 'reftex-view-crossref-when-idle reftex-idle-time nil t)))) +(declare-function bibtex-beginning-of-entry "bibtex" ()) + (defun reftex-view-crossref-from-bibtex (&optional arg) "View location in a LaTeX document which cites the BibTeX entry at point. Since BibTeX files can be used by many LaTeX documents, this function diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index f430e9bd01a..73bcf6d6a74 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -39,6 +39,9 @@ (defvar transient-mark-mode) (defvar TeX-master) ;; END remove for XEmacs release + +(declare-function texmathp "ext:texmathp" ()) + (defun reftex-index-selection-or-word (&optional arg phrase) "Put selection or the word near point into the default index macro. This uses the information in `reftex-index-default-macro' to make an index diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el index ae147cc6b97..d1d979b3fc0 100644 --- a/lisp/textmodes/reftex-toc.el +++ b/lisp/textmodes/reftex-toc.el @@ -995,8 +995,10 @@ always show the current section in connection with the option (select-frame current-toc-frame) (switch-to-buffer "*toc*") (select-frame current-frame) - (if (fboundp 'focus-frame) (focus-frame current-frame) - (if (fboundp 'x-focus-frame) (x-focus-frame current-frame))) + (if (fboundp 'x-focus-frame) (x-focus-frame current-frame) + ;; focus-frame has done nothing in Emacs since at least v21. + (if (featurep 'xemacs) + (if (fboundp 'focus-frame) (focus-frame current-frame)))) (select-window current-window) (when (eq reftex-auto-recenter-toc 'frame) (unless reftex-toc-auto-recenter-timer diff --git a/lisp/textmodes/remember-diary.el b/lisp/textmodes/remember-diary.el deleted file mode 100644 index e35909fb589..00000000000 --- a/lisp/textmodes/remember-diary.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; remember-diary --- extracting diary information from buffers - -;; Copyright (C) 1999, 2000, 2001, 2004, 2007 Free Software Foundation, Inc. - -;; Author: Sacha Chua <sacha@free.net.ph> -;; Created: 24 Mar 2004 -;; Keywords: data memory todo pim diary -;; URL: http://gna.org/projects/remember-el/ - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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 3, or (at your option) -;; any later version. - -;; GNU Emacs 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. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; This module recognizes entries of the form -;; -;; DIARY: .... -;; -;; and puts them in your ~/.diary (or remember-diary-file) together -;; with an annotation. Planner-style dates (yyyy.mm.dd) are converted -;; to yyyy-mm-dd so that diary can understand them. -;; -;; For example: -;; -;; DIARY: 2003.08.12 Sacha's birthday -;; -;; is stored as -;; -;; 2003.08.12 Sacha's birthday [[/home/sacha/notebook/emacs/emacs-wiki/remember-diary.el]] -;; -;; To use, add the following to your .emacs: -;; -;; (require 'remember-diary) -;; ;; This should be before other entries that may return t -;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) -;; - -(require 'remember) -(require 'diary-lib) - -;;; Code: -(defcustom remember-diary-file diary-file - "*File for extracted diary entries." - :type 'file - :group 'remember) - -(defun remember-diary-convert-entry (entry) - "Translate MSG to an entry readable by diary." - (save-match-data - (when remember-annotation - (setq entry (concat entry " " remember-annotation))) - (if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)" entry) - (replace-match - (if european-calendar-style - (concat (match-string 3 entry) "/" - (match-string 2 entry) "/" - (match-string 1 entry)) - (concat (match-string 2 entry) "/" - (match-string 3 entry) "/" - (match-string 1 entry))) - t t entry) - entry))) - -;;;###autoload -(defun remember-diary-extract-entries () - "Extract diary entries from the region." - (save-excursion - (goto-char (point-min)) - (let (list) - (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) - (add-to-list 'list (remember-diary-convert-entry (match-string 1)))) - (when list - (make-diary-entry (mapconcat 'identity list "\n") - nil remember-diary-file)) - nil))) ;; Continue processing - -(provide 'remember-diary) - -;; arch-tag: bda8a3f8-9a9b-46aa-8493-d71d7f1e445d -;;; remember-diary.el ends here diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 7249f1d4c57..81be7ace146 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -153,6 +153,29 @@ ;; Faridu'd-Din `Attar wrote: "Be occupied as little as possible with ;; things of the outer world but much with things of the inner world; ;; then right action will overcome inaction." +;; +;; * Diary integration +;; +;; To use, add the following to your .emacs: +;; +;; ;; This should be before other entries that may return t +;; (add-to-list 'remember-handler-functions 'remember-diary-extract-entries) +;; +;; This module recognizes entries of the form +;; +;; DIARY: .... +;; +;; and puts them in your ~/.diary (or remember-diary-file) together +;; with an annotation. Dates in the form YYYY.MM.DD are converted to +;; YYYY-MM-DD so that diary can understand them. +;; +;; For example: +;; +;; DIARY: 2003.08.12 Sacha's birthday +;; +;; is stored as +;; +;; 2003.08.12 Sacha's birthday ;;; History: @@ -440,6 +463,46 @@ application." (kill-buffer (current-buffer)) (jump-to-register remember-register))) +;;; Diary integration + +(defcustom remember-diary-file nil + "*File for extracted diary entries. +If this is nil, then `diary-file' will be used instead." + :type 'file + :group 'remember) + +(defun remember-diary-convert-entry (entry) + "Translate MSG to an entry readable by diary." + (save-match-data + (when remember-annotation + (setq entry (concat entry " " remember-annotation))) + (if (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)\\.\\([0-9]+\\)" entry) + (replace-match + (if european-calendar-style + (concat (match-string 3 entry) "/" + (match-string 2 entry) "/" + (match-string 1 entry)) + (concat (match-string 2 entry) "/" + (match-string 3 entry) "/" + (match-string 1 entry))) + t t entry) + entry))) + +(autoload 'make-diary-entry "diary-lib") + +;;;###autoload +(defun remember-diary-extract-entries () + "Extract diary entries from the region." + (save-excursion + (goto-char (point-min)) + (let (list) + (while (re-search-forward "^DIARY:\\s-*\\(.+\\)" nil t) + (add-to-list 'list (remember-diary-convert-entry (match-string 1)))) + (when list + (make-diary-entry (mapconcat 'identity list "\n") + nil (or remember-diary-file diary-file))) + nil))) ;; Continue processing + ;;; Internal Functions: (defvar remember-mode-map diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el index 73b6ec3920e..55e7134f87e 100644 --- a/lisp/textmodes/texinfmt.el +++ b/lisp/textmodes/texinfmt.el @@ -3001,14 +3001,17 @@ Default is to leave paragraph indentation as is." (put 'printindex 'texinfo-format 'texinfo-format-printindex) (defun texinfo-format-printindex () - (let ((indexelts (symbol-value - (cdr (assoc (texinfo-parse-arg-discard) - texinfo-indexvar-alist)))) - opoint) + (let* ((arg (texinfo-parse-arg-discard)) + (fmt (cdr (assoc arg texinfo-short-index-format-cmds-alist))) + (index-list (delq nil (mapcar (lambda (e) + (and (eq fmt (get (cdr e) 'texinfo-format)) + (cdr (assoc (car e) texinfo-indexvar-alist)))) + texinfo-short-index-cmds-alist))) + (indexelts (apply #'append nil (mapcar #'symbol-value index-list))) + opoint) (insert "\n* Menu:\n\n") (setq opoint (point)) (texinfo-print-index nil indexelts) - (if (memq system-type '(vax-vms windows-nt ms-dos)) (texinfo-sort-region opoint (point)) (shell-command-on-region opoint (point) "sort -fd" 1)))) diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index 93552c15ea9..9d86733ab98 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,68 @@ +2007-12-06 Glenn Morris <rgm@gnu.org> + + * url-file.el, url-mailto.el: Remove directory part from filenames + in function declarations. + +2007-12-02 Glenn Morris <rgm@gnu.org> + + * url-about.el, url-handlers.el: Don't require cl when compiling. + + * url-dav.el (url-dav-delete-directory): Fix message typo. + + * url-history.el (top-level): Don't require cl when compiling. + (url-history-setup-save-timer, url-history-save-history): + Use condition-case rather than ignore-errors. + + * url-imap.el (top-level): Don't require cl when compiling. + (url-imap): Use signal rather than check-type. + + * url-news.el (top-level): Don't require cl when compiling. + (gnus-group-buffer): Define for compiler. + (url-news-fetch-message-id): Don't use `declare'. + (nntp-open-tls-stream, nntp-open-ssl-stream): + No need to define for compiler. + (url-snews): Use nntp-open-tls-stream unless ssl is requested. + Correct quoting of nntp-open-connection-function value. + +2007-12-01 Glenn Morris <rgm@gnu.org> + + * url-handlers.el (top-level): Always require url-parse, not just + when compiling. + +2007-11-30 Glenn Morris <rgm@gnu.org> + + * url-cookie.el (url-cookie-p): Declare as a function. + +2007-11-29 Glenn Morris <rgm@gnu.org> + + * url-file.el (url-file-build-filename, url-file): Wrap uses of + efs in (featurep 'xemacs) test. + + * url-irc.el (zenirc, zenirc-send-line): Declare as functions. + +2007-11-28 Diane Murray <disumu@x3y2z1.net> + + * url-dired.el: Don't require w3-fetch and w3-open-local. + (url-dired-find-file): Use `find-file'. Doc fix. + (url-dired-find-file-mouse, url-dired-minor-mode): Doc fix. + +2007-11-24 Glenn Morris <rgm@gnu.org> + + * url-privacy.el (url-device-type): Fix typo. + +2007-11-20 Dan Nicolaescu <dann@ics.uci.edu> + + * url-mailto.el (mail-send-and-exit): + * url-http.el (url-dav-file-attributes): + * url-file.el (ange-ftp-set-passwd, ange-ftp-copy-file-internal) + (url-generate-unique-filename): Declare as functions. + + * url-privacy.el (url-device-type): Define unconditionally. + +2007-11-15 Richard Stallman <rms@gnu.org> + + * url.el (url-retrieve-synchronously): Call delete-process. + 2007-10-31 Juanma Barranquero <lekktu@gmail.com> * url-vars.el (url-vars-unload-hook): Remove function and variable. diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el index 5ed16bb2f81..4a16fe7e122 100644 --- a/lisp/url/url-about.el +++ b/lisp/url/url-about.el @@ -25,8 +25,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) (require 'url-util) (require 'url-parse) diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 368c34e32a8..bc0fea4de44 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -87,6 +87,8 @@ telling Microsoft that." ;; (message "Could not load cookie file %s" fname) ))) +(declare-function url-cookie-p "url-cookie" t t) ; defstruct + (defun url-cookie-clean-up (&optional secure) (let* ( (var (if secure 'url-cookie-secure-storage 'url-cookie-storage)) diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el index 3c2ea872134..fafea4c1f0e 100644 --- a/lisp/url/url-dav.el +++ b/lisp/url/url-dav.el @@ -746,7 +746,7 @@ files in the collection as well." (setq status (plist-get (cdr result) 'DAV:status)) (if (not (url-dav-http-success-p status)) (signal 'file-error (list "Removing directory" - "Errror removing" + "Error removing" (car result) status)))) props)) nil) diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el index 189628468b7..93c99447555 100644 --- a/lisp/url/url-dired.el +++ b/lisp/url/url-dired.el @@ -24,8 +24,6 @@ ;;; Code: -(autoload 'w3-fetch "w3") -(autoload 'w3-open-local "w3") (autoload 'dired-get-filename "dired") (defvar url-dired-minor-mode-map @@ -41,22 +39,19 @@ (make-variable-buffer-local 'url-dired-minor-mode) (defun url-dired-find-file () - "In dired, visit the file or directory named on this line, using Emacs-W3." + "In dired, visit the file or directory named on this line." (interactive) (let ((filename (dired-get-filename))) - (cond ((string-match "/\\(.*@.*\\):\\(/.*\\)" filename) - (w3-fetch (concat "file://" (match-string 1 filename) (match-string 2 filename)))) - (t - (w3-open-local filename))))) + (find-file filename))) (defun url-dired-find-file-mouse (event) - "In dired, visit the file or directory name you click on, using Emacs-W3." + "In dired, visit the file or directory name you click on." (interactive "@e") (mouse-set-point event) (url-dired-find-file)) (defun url-dired-minor-mode (&optional arg) - "Minor mode for directory browsing with Emacs-W3." + "Minor mode for directory browsing." (interactive "P") (cond ((null arg) diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index c361016856b..f9c9cd33d04 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -86,6 +86,12 @@ to them." (error nil))) (apply func args)))) +(declare-function ange-ftp-set-passwd "ange-ftp" (host user passwd)) +(declare-function ange-ftp-copy-file-internal "ange-ftp" + (filename newname ok-if-already-exists + keep-date &optional msg cont nowait)) +(declare-function url-generate-unique-filename "url-util" (&optional fmt)) + (defun url-file-build-filename (url) (if (not (vectorp url)) (setq url (url-generic-parse-url url))) @@ -113,8 +119,9 @@ to them." (cond ((featurep 'ange-ftp) (ange-ftp-set-passwd host user pass)) - ((or (featurep 'efs) (featurep 'efs-auto)) - (efs-set-passwd host user pass)) + ((when (featurep 'xemacs) + (or (featurep 'efs) (featurep 'efs-auto) + (efs-set-passwd host user pass)))) (t nil))) @@ -208,14 +215,15 @@ to them." new (current-buffer) callback cbargs) t) - (autoload 'efs-copy-file-internal "efs") - (efs-copy-file-internal filename (efs-ftp-path filename) - new (efs-ftp-path new) - t nil 0 - (list 'url-file-asynch-callback - new (current-buffer) - callback cbargs) - 0 nil)))))) + (when (featurep 'xemacs) + (autoload 'efs-copy-file-internal "efs") + (efs-copy-file-internal filename (efs-ftp-path filename) + new (efs-ftp-path new) + t nil 0 + (list 'url-file-asynch-callback + new (current-buffer) + callback cbargs) + 0 nil))))))) buffer)) (defmacro url-file-create-wrapper (method args) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index d6776c238e0..d22076a8b4f 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -27,7 +27,7 @@ ;;; Code: ;; (require 'url) -(eval-when-compile (require 'url-parse)) +(require 'url-parse) ;; (require 'url-util) (eval-when-compile (require 'mm-decode)) ;; (require 'mailcap) @@ -41,9 +41,6 @@ (autoload 'mm-dissect-buffer "mm-decode" "Dissect the current buffer and return a list of MIME handles.") (autoload 'url-scheme-get-property "url-methods" "Get property of a URL SCHEME.") -(eval-when-compile - (require 'cl)) - ;; Implementation status ;; --------------------- ;; Function Status diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el index 1ed3c71174e..605ffa0145f 100644 --- a/lisp/url/url-history.el +++ b/lisp/url/url-history.el @@ -28,7 +28,6 @@ ;; This can get a recursive require. ;;(require 'url) -(eval-when-compile (require 'cl)) (require 'url-parse) (autoload 'url-do-setup "url") @@ -83,8 +82,9 @@ to run the `url-history-setup-save-timer' function manually." (defun url-history-setup-save-timer () "Reset the history list timer." (interactive) - (ignore-errors - (cancel-timer url-history-timer)) + (condition-case nil + (cancel-timer url-history-timer) + (error nil)) (setq url-history-timer nil) (if (and (eq url-history-track t) url-history-save-interval) (setq url-history-timer (run-at-time url-history-save-interval @@ -120,7 +120,9 @@ user for what type to save as." (interactive) (or fname (setq fname (expand-file-name url-history-file))) (unless (file-directory-p (file-name-directory fname)) - (ignore-errors (make-directory (file-name-directory fname)))) + (condition-case nil + (make-directory (file-name-directory fname)) + (error nil))) (cond ((not url-history-changed-since-last-save) nil) ((not (file-writable-p fname)) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index c5931c7d877..c8447dab859 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -1269,6 +1269,8 @@ CBARGS as the arguments." nil nil nil) ;whether gid would change ; inode ; device. (kill-buffer buffer))))) +(declare-function url-dav-file-attributes (url &optional id-format)) + ;;;###autoload (defun url-http-file-attributes (url &optional id-format) (if (url-dav-supported-p url) diff --git a/lisp/url/url-imap.el b/lisp/url/url-imap.el index 5c5dff31f76..3b1d9e24dbc 100644 --- a/lisp/url/url-imap.el +++ b/lisp/url/url-imap.el @@ -32,7 +32,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'url-util) (require 'url-parse) (require 'nnimap) @@ -53,7 +52,8 @@ (nnimap-authenticator ,authenticator))))) (defun url-imap (url) - (check-type url vector "Need a pre-parsed URL.") + (unless (vectorp url) + (signal 'wrong-type-error (list "Need a pre-parsed URL." url))) (save-excursion (set-buffer (generate-new-buffer " *url-imap*")) (mm-disable-multibyte) diff --git a/lisp/url/url-irc.el b/lisp/url/url-irc.el index 0cefb375bf3..2c3155e49ce 100644 --- a/lisp/url/url-irc.el +++ b/lisp/url/url-irc.el @@ -47,6 +47,10 @@ PASSWORD - What password to use" (function :tag "Other")) :group 'url) +;; External. +(declare-function zenirc "ext:zenirc" (&optional prefix)) +(declare-function zenirc-send-line "ext:zenirc" ()) + (defun url-irc-zenirc (host port channel user password) (let ((zenirc-buffer-name (if (and user host port) (format "%s@%s:%d" user host port) diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el index 4b15d07245b..160c6db98d7 100644 --- a/lisp/url/url-mailto.el +++ b/lisp/url/url-mailto.el @@ -60,6 +60,8 @@ (save-excursion (insert "\n")))))) +(declare-function mail-send-and-exit "sendmail") + ;;;###autoload (defun url-mailto (url) "Handle the mailto: URL syntax." diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el index d774270aced..fc1f0091547 100644 --- a/lisp/url/url-news.el +++ b/lisp/url/url-news.el @@ -30,9 +30,6 @@ (require 'nntp) (autoload 'url-warn "url") (autoload 'gnus-group-read-ephemeral-group "gnus-group") -(eval-when-compile (require 'cl)) -(defvar nntp-open-tls-stream) -(defvar nntp-open-ssl-stream) (defgroup url-news nil "News related options." @@ -85,8 +82,9 @@ ))) buf)) +(defvar gnus-group-buffer) + (defun url-news-fetch-newsgroup (newsgroup host) - (declare (special gnus-group-buffer)) (if (string-match "^/+" newsgroup) (setq newsgroup (substring newsgroup (match-end 0)))) (if (string-match "/+$" newsgroup) @@ -127,9 +125,9 @@ ;;;###autoload (defun url-snews (url) - (let ((nntp-open-connection-function (if (eq 'tls url-gateway-method) - nntp-open-tls-stream - nntp-open-ssl-stream))) + (let ((nntp-open-connection-function (if (eq 'ssl url-gateway-method) + 'nntp-open-ssl-stream + 'nntp-open-tls-stream))) (url-news url))) (provide 'url-news) diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index 6c29474752b..e7c189ebf41 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -27,9 +27,10 @@ (eval-when-compile (require 'cl)) (require 'url-vars) -(if (fboundp 'device-type) - (defalias 'url-device-type 'device-type) - (defun url-device-type (&optional device) (or window-system 'tty))) +(defun url-device-type (&optional device) + (if (fboundp 'device-type) + (device-type device) ; XEmacs + (or window-system 'tty))) ;;;###autoload (defun url-setup-privacy-info () diff --git a/lisp/url/url.el b/lisp/url/url.el index 3b292b4452d..c375a75e06f 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -241,7 +241,9 @@ no further processing). URL is either a string or a parsed URL." ;; XXX: The callback must always be called. Any ;; exception is a bug that should be fixed, not worked ;; around. - (setq retrieval-done t)) + (progn ;; Call delete-process so we run any sentinel now. + (delete-process proc) + (setq retrieval-done t))) ;; We used to use `sit-for' here, but in some cases it wouldn't ;; work because apparently pending keyboard input would always ;; interrupt it before it got a chance to handle process input. diff --git a/lisp/vc-cvs.el b/lisp/vc-cvs.el index d6573db9df2..c9c50fceba2 100644 --- a/lisp/vc-cvs.el +++ b/lisp/vc-cvs.el @@ -513,15 +513,46 @@ The changes are between FIRST-REVISION and SECOND-REVISION." (defun vc-cvs-diff (files &optional oldvers newvers buffer) "Get a difference report using CVS between two revisions of FILE." - (let* ((async (and (not vc-disable-async-diff) - (vc-stay-local-p files))) - (status (apply 'vc-cvs-command (or buffer "*vc-diff*") + (let* ((async (and (not vc-disable-async-diff) + (vc-stay-local-p files))) + (invoke-cvs-diff-list nil) + status) + ;; Look through the file list and see if any files have backups + ;; that can be used to do a plain "diff" instead of "cvs diff". + (dolist (file files) + (let ((ov oldvers) + (nv newvers)) + (when (or (not ov) (string-equal ov "")) + (setq ov (vc-working-revision file))) + (when (string-equal nv "") + (setq nv nil)) + (let ((file-oldvers (vc-version-backup-file file ov)) + (file-newvers (if (not nv) + file + (vc-version-backup-file file nv))) + (coding-system-for-read (vc-coding-system-for-diff file))) + (if (and file-oldvers file-newvers) + (progn + (apply 'vc-do-command (or buffer "*vc-diff*") 1 "diff" nil + (append (if (listp diff-switches) + diff-switches + (list diff-switches)) + (if (listp vc-diff-switches) + vc-diff-switches + (list vc-diff-switches)) + (list (file-relative-name file-oldvers) + (file-relative-name file-newvers)))) + (setq status 0)) + (push file invoke-cvs-diff-list))))) + (when invoke-cvs-diff-list + (setq status (apply 'vc-cvs-command (or buffer "*vc-diff*") (if async 'async 1) - files "diff" + invoke-cvs-diff-list "diff" (and oldvers (concat "-r" oldvers)) (and newvers (concat "-r" newvers)) (vc-switches 'CVS 'diff)))) - (if async 1 status))) ; async diff, pessimistic assumption + (if async 1 status))) ; async diff, pessimistic assumption + (defun vc-cvs-diff-tree (dir &optional rev1 rev2) "Diff all files at and below DIR." diff --git a/lisp/vc-git.el b/lisp/vc-git.el index 07714b26c32..6fd6849281b 100644 --- a/lisp/vc-git.el +++ b/lisp/vc-git.el @@ -81,7 +81,7 @@ ;; HISTORY FUNCTIONS ;; * print-log (files &optional buffer) OK ;; - log-view-mode () OK -;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD +;; - show-log-entry (revision) OK ;; - wash-log (file) COULD BE SUPPORTED ;; - logentry-check () NOT NEEDED ;; - comment-history (file) ?? @@ -116,7 +116,7 @@ ;;; BACKEND PROPERTIES (defun vc-git-revision-granularity () - 'repository) + 'repository) ;;; STATE-QUERYING FUNCTIONS @@ -134,23 +134,25 @@ (let* ((dir (file-name-directory file)) (name (file-relative-name file dir))) (and (ignore-errors - (when dir (cd dir)) - (eq 0 (call-process "git" nil '(t nil) nil "ls-files" "-c" "-z" "--" name))) + (when dir (cd dir)) + (vc-git--out-ok "ls-files" "-c" "-z" "--" name)) (let ((str (buffer-string))) (and (> (length str) (length name)) - (string= (substring str 0 (1+ (length name))) (concat name "\0"))))))))) + (string= (substring str 0 (1+ (length name))) + (concat name "\0"))))))))) (defun vc-git-state (file) "Git-specific version of `vc-state'." - (call-process "git" nil nil nil "add" "--refresh" "--" (file-relative-name file)) + (vc-git--call nil "add" "--refresh" "--" (file-relative-name file)) (let ((diff (vc-git--run-command-string file "diff-index" "-z" "HEAD" "--"))) - (if (and diff (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} [ADMU]\0[^\0]+\0" diff)) + (if (and diff (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} [ADMU]\0[^\0]+\0" + diff)) 'edited 'up-to-date))) (defun vc-git-dir-state (dir) (with-temp-buffer - (vc-git-command (current-buffer) nil nil "ls-files" "-t") + (vc-git-command (current-buffer) nil nil "ls-files" "-t" "-c" "-m" "-o") (goto-char (point-min)) (let ((status-char nil) (file nil)) @@ -158,7 +160,8 @@ (setq status-char (char-after)) (setq file (expand-file-name - (buffer-substring-no-properties (+ (point) 2) (line-end-position)))) + (buffer-substring-no-properties (+ (point) 2) + (line-end-position)))) (cond ;; The rest of the possible states in "git ls-files -t" output: ;; R removed/deleted @@ -180,7 +183,7 @@ "Git-specific version of `vc-working-revision'." (let ((str (with-output-to-string (with-current-buffer standard-output - (call-process "git" nil '(t nil) nil "symbolic-ref" "HEAD"))))) + (vc-git--out-ok "symbolic-ref" "HEAD"))))) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) (match-string 2 str) str))) @@ -290,33 +293,48 @@ "^commit *\\([0-9a-z]+\\)") (set (make-local-variable 'log-view-font-lock-keywords) (append - `((,log-view-message-re (1 'change-log-acknowledgement)) - (,log-view-file-re (1 'change-log-file-face))) - ;; Handle the case: - ;; user: foo@bar - '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" - (1 'change-log-email)) - ;; Handle the case: - ;; user: FirstName LastName <foo@bar> - ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" - (1 'change-log-name)) - ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" - (1 'change-log-name) - (2 'change-log-email)) - ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" - (1 'change-log-acknowledgement) - (2 'change-log-acknowledgement)) - ("^Date: \\(.+\\)" (1 'change-log-date)) - ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))) + `((,log-view-message-re (1 'change-log-acknowledgement)) + (,log-view-file-re (1 'change-log-file-face))) + ;; Handle the case: + ;; user: foo@bar + '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" + (1 'change-log-email)) + ;; Handle the case: + ;; user: FirstName LastName <foo@bar> + ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + (1 'change-log-name) + (2 'change-log-email)) + ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)" + (1 'change-log-name)) + ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]" + (1 'change-log-name) + (2 'change-log-email)) + ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" + (1 'change-log-acknowledgement) + (2 'change-log-acknowledgement)) + ("^Date: \\(.+\\)" (1 'change-log-date)) + ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))) + +(defun vc-git-show-log-entry (revision) + "Move to the log entry for REVISION. +REVISION may have the form BRANCH, BRANCH~N, +or BRANCH^ (where \"^\" can be repeated)." + (goto-char (point-min)) + (search-forward "\ncommit" nil t + (cond ((string-match "~\\([0-9]\\)$" revision) + (1+ (string-to-number (match-string 1 revision)))) + ((string-match "\\^+$" revision) + (1+ (length (match-string 0 revision)))) + (t nil))) + (beginning-of-line)) (defun vc-git-diff (files &optional rev1 rev2 buffer) (let ((buf (or buffer "*vc-diff*"))) (if (and rev1 rev2) - (vc-git-command buf 1 files "diff-tree" "--exit-code" "-p" rev1 rev2 "--") - (vc-git-command buf 1 files "diff-index" "--exit-code" "-p" (or rev1 "HEAD") "--")))) + (vc-git-command buf 1 files "diff-tree" "--exit-code" "-p" + rev1 rev2 "--") + (vc-git-command buf 1 files "diff-index" "--exit-code" "-p" + (or rev1 "HEAD") "--")))) (defun vc-git-revision-table (files) ;; What about `files'?!? --Stef @@ -341,15 +359,17 @@ (vc-git-command buf 0 name "blame" (if rev (concat "-r" rev))))) (defun vc-git-annotate-time () - (and (re-search-forward "[0-9a-f]+ (.* \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\) +[0-9]+)" nil t) + (and (re-search-forward "[0-9a-f]+[^()]+(.* \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\) +[0-9]+) " nil t) (vc-annotate-convert-time - (apply #'encode-time (mapcar (lambda (match) (string-to-number (match-string match))) '(6 5 4 3 2 1 7)))))) + (apply #'encode-time (mapcar (lambda (match) + (string-to-number (match-string match))) + '(6 5 4 3 2 1 7)))))) (defun vc-git-annotate-extract-revision-at-line () - (save-excursion - (move-beginning-of-line 1) - (and (looking-at "[0-9a-f]+") - (buffer-substring-no-properties (match-beginning 0) (match-end 0))))) + (save-excursion + (move-beginning-of-line 1) + (and (looking-at "[0-9a-f]+") + (buffer-substring-no-properties (match-beginning 0) (match-end 0))))) ;;; SNAPSHOT SYSTEM @@ -376,42 +396,36 @@ (vc-git-symbolic-commit (with-temp-buffer (and - (zerop - (call-process "git" nil '(t nil) nil "rev-list" - "-2" rev "--" file)) + (vc-git--out-ok "rev-list" "-2" rev "--" file) (goto-char (point-max)) (bolp) (zerop (forward-line -1)) (not (bobp)) (buffer-substring-no-properties - (point) - (1- (point-max)))))))) + (point) + (1- (point-max)))))))) (defun vc-git-next-revision (file rev) "Git-specific version of `vc-next-revision'." (let* ((default-directory (file-name-directory (expand-file-name file))) - (file (file-name-nondirectory file)) - (current-rev - (with-temp-buffer - (and - (zerop - (call-process "git" nil '(t nil) nil "rev-list" - "-1" rev "--" file)) - (goto-char (point-max)) - (bolp) - (zerop (forward-line -1)) - (bobp) - (buffer-substring-no-properties - (point) - (1- (point-max))))))) + (file (file-name-nondirectory file)) + (current-rev + (with-temp-buffer + (and + (vc-git--out-ok "rev-list" "-1" rev "--" file) + (goto-char (point-max)) + (bolp) + (zerop (forward-line -1)) + (bobp) + (buffer-substring-no-properties + (point) + (1- (point-max))))))) (and current-rev (vc-git-symbolic-commit (with-temp-buffer (and - (zerop - (call-process "git" nil '(t nil) nil "rev-list" - "HEAD" "--" file)) + (vc-git--out-ok "rev-list" "HEAD" "--" file) (goto-char (point-min)) (search-forward current-rev nil t) (zerop (forward-line -1)) @@ -436,13 +450,20 @@ The difference to vc-do-command is that this function always invokes `git'." (apply 'vc-do-command buffer okstatus "git" file-or-list flags)) +(defun vc-git--call (buffer command &rest args) + (apply 'call-process "git" nil buffer nil command args)) + +(defun vc-git--out-ok (command &rest args) + (zerop (apply 'vc-git--call '(t nil) command args))) + (defun vc-git--run-command-string (file &rest args) "Run a git command on FILE and return its output as string." (let* ((ok t) (str (with-output-to-string (with-current-buffer standard-output - (unless (eq 0 (apply #'call-process "git" nil '(t nil) nil - (append args (list (file-relative-name file))))) + (unless (apply 'vc-git--out-ok + (append args (list (file-relative-name + file)))) (setq ok nil)))))) (and ok str))) @@ -452,10 +473,7 @@ Returns nil if not possible." (and commit (with-temp-buffer (and - (zerop - (call-process "git" nil '(t nil) nil "name-rev" - "--name-only" "--tags" - commit)) + (vc-git--out-ok "name-rev" "--name-only" "--tags" commit) (goto-char (point-min)) (= (forward-line 2) 1) (bolp) diff --git a/lisp/vc-hg.el b/lisp/vc-hg.el index 872be45a2c1..af2b4f133d2 100644 --- a/lisp/vc-hg.el +++ b/lisp/vc-hg.el @@ -296,7 +296,7 @@ (defun vc-hg-revision-table (files) (let ((default-directory (file-name-directory (car files)))) (with-temp-buffer - (vc-hg-command t nil file "log" "--template" "{rev} ") + (vc-hg-command t nil files "log" "--template" "{rev} ") (split-string (buffer-substring-no-properties (point-min) (point-max)))))) @@ -480,6 +480,8 @@ REV is the revision to check out into WORKFILE." (pop-to-buffer bname) (vc-hg-incoming-mode))) +(declare-function log-view-get-marked "log-view" ()) + ;; XXX maybe also add key bindings for these functions. (defun vc-hg-push () (interactive) diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el index e28a01d35e6..80f12af974a 100644 --- a/lisp/vc-hooks.el +++ b/lisp/vc-hooks.el @@ -705,6 +705,8 @@ Before doing that, check if there are any old backups and get rid of them." (vc-call make-version-backups-p file) (vc-make-version-backup file)))) +(declare-function vc-dired-resynch-file "vc" (file)) + (defun vc-after-save () "Function to be called by `basic-save-buffer' (in files.el)." ;; If the file in the current buffer is under version control, diff --git a/lisp/vc.el b/lisp/vc.el index 5811b2f7d63..622c9682fbc 100644 --- a/lisp/vc.el +++ b/lisp/vc.el @@ -83,8 +83,8 @@ ;; to be installed somewhere on Emacs's path for executables. ;; ;; If your site uses the ChangeLog convention supported by Emacs, the -;; function log-edit-comment-to-change-log could prove a useful checkin hook, -;; although you might prefer to use C-c C-a (i.e. log-edit-insert-changelog) +;; function `log-edit-comment-to-change-log' could prove a useful checkin hook, +;; although you might prefer to use C-c C-a (i.e. `log-edit-insert-changelog') ;; from the commit buffer instead or to set `log-edit-setup-invert'. ;; ;; The vc code maintains some internal state in order to reduce expensive @@ -774,6 +774,7 @@ List of factors, used to expand/compress the time scale. See `vc-annotate'." (define-key m "N" 'vc-annotate-next-revision) (define-key m "P" 'vc-annotate-prev-revision) (define-key m "W" 'vc-annotate-working-revision) + (define-key m "V" 'vc-annotate-toggle-annotation-visibility) m) "Local keymap used for VC-Annotate mode.") @@ -1267,7 +1268,9 @@ Otherwise, throw an error." marked)) ((vc-backend buffer-file-name) (list buffer-file-name)) - ((and vc-parent-buffer (buffer-file-name vc-parent-buffer)) + ((and vc-parent-buffer (or (buffer-file-name vc-parent-buffer) + (with-current-buffer vc-parent-buffer + vc-dired-mode))) (progn (set-buffer vc-parent-buffer) (vc-deduce-fileset))) @@ -1535,8 +1538,9 @@ merge in the changes into your working copy." (vc-call-backend backend 'create-repo)) ;;;###autoload -(defun vc-register (&optional set-revision comment) - "Register the current file into a version control system. +(defun vc-register (&optional fname set-revision comment) + "Register into a version control system. +If FNAME is given register that file, otherwise register the current file. With prefix argument SET-REVISION, allow user to specify initial revision level. If COMMENT is present, use that as an initial comment. @@ -1547,40 +1551,44 @@ directory are already registered under that backend) will be used to register the file. If no backend declares itself responsible, the first backend that could register the file is used." (interactive "P") - (unless buffer-file-name (error "No visited file")) - (when (vc-backend buffer-file-name) - (if (vc-registered buffer-file-name) - (error "This file is already registered") - (unless (y-or-n-p "Previous master file has vanished. Make a new one? ") - (error "Aborted")))) - ;; Watch out for new buffers of size 0: the corresponding file - ;; does not exist yet, even though buffer-modified-p is nil. - (if (and (not (buffer-modified-p)) - (zerop (buffer-size)) - (not (file-exists-p buffer-file-name))) - (set-buffer-modified-p t)) - (vc-buffer-sync) - - (vc-start-entry (list buffer-file-name) - (if set-revision - (read-string (format "Initial revision level for %s: " - (buffer-name))) - (vc-call-backend (vc-responsible-backend buffer-file-name) - 'init-revision)) - (or comment (not vc-initial-comment)) - nil - "Enter initial comment." - (lambda (files rev comment) - (dolist (file files) - (message "Registering %s... " file) - (let ((backend (vc-responsible-backend file t))) - (vc-file-clearprops file) - (vc-call-backend backend 'register (list file) rev comment) - (vc-file-setprop file 'vc-backend backend) - (unless vc-make-backup-files - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) - (message "Registering %s... done" file))))) + (when (and (null fname) (null buffer-file-name)) (error "No visited file")) + + (let ((bname (if fname (get-file-buffer fname) buffer-file-name))) + (unless fname (setq fname buffer-file-name)) + (when (vc-backend fname) + (if (vc-registered fname) + (error "This file is already registered") + (unless (y-or-n-p "Previous master file has vanished. Make a new one? ") + (error "Aborted")))) + ;; Watch out for new buffers of size 0: the corresponding file + ;; does not exist yet, even though buffer-modified-p is nil. + (when bname + (with-current-buffer bname + (if (and (not (buffer-modified-p)) + (zerop (buffer-size)) + (not (file-exists-p buffer-file-name))) + (set-buffer-modified-p t)) + (vc-buffer-sync))) + (vc-start-entry (list fname) + (if set-revision + (read-string (format "Initial revision level for %s: " + fname)) + (vc-call-backend (vc-responsible-backend fname) + 'init-revision)) + (or comment (not vc-initial-comment)) + nil + "Enter initial comment." + (lambda (files rev comment) + (dolist (file files) + (message "Registering %s... " file) + (let ((backend (vc-responsible-backend file t))) + (vc-file-clearprops file) + (vc-call-backend backend 'register (list file) rev comment) + (vc-file-setprop file 'vc-backend backend) + (unless vc-make-backup-files + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (message "Registering %s... done" file)))))) (defun vc-register-with (backend) "Register the current file with a specified back end." @@ -1590,6 +1598,8 @@ first backend that could register the file is used." (let ((vc-handled-backends (list backend))) (call-interactively 'vc-register))) +(declare-function view-mode-exit "view" (&optional return-to-alist exit-action all-win)) + (defun vc-resynch-window (file &optional keep noquery) "If FILE is in the current buffer, either revert or unvisit it. The choice between revert (to see expanded keywords) and unvisit depends on @@ -1637,14 +1647,18 @@ empty comment. Remember the file's buffer in `vc-parent-buffer' \(current one if no file). AFTER-HOOK specifies the local value for vc-log-operation-hook." (let ((parent - (if (and files (equal (length files) 1)) - (get-file-buffer (car files)) - (current-buffer)))) - (if vc-before-checkin-hook - (if files - (with-current-buffer parent - (run-hooks 'vc-before-checkin-hook)) - (run-hooks 'vc-before-checkin-hook))) + (if (eq major-mode 'vc-dired-mode) + ;; If we are called from VC dired, the parent buffer is + ;; the current buffer. + (current-buffer) + (if (and files (equal (length files) 1)) + (get-file-buffer (car files)) + (current-buffer))))) + (when vc-before-checkin-hook + (if files + (with-current-buffer parent + (run-hooks 'vc-before-checkin-hook)) + (run-hooks 'vc-before-checkin-hook))) (if (and comment (not initial-contents)) (set-buffer (get-buffer-create "*VC-log*")) (pop-to-buffer (get-buffer-create "*VC-log*"))) @@ -1654,8 +1668,8 @@ for vc-log-operation-hook." ;;(if file (vc-mode-line file)) (vc-log-edit files) (make-local-variable 'vc-log-after-operation-hook) - (if after-hook - (setq vc-log-after-operation-hook after-hook)) + (when after-hook + (setq vc-log-after-operation-hook after-hook)) (setq vc-log-operation action) (setq vc-log-revision rev) (when comment @@ -1929,13 +1943,14 @@ returns t if the buffer had changes, nil otherwise." (progn (message "No changes between %s and %s" rev1-name rev2-name) nil) - (pop-to-buffer (current-buffer)) (diff-mode) ;; Make the *vc-diff* buffer read only, the diff-mode key ;; bindings are nicer for read only buffers. pcl-cvs does the ;; same thing. (setq buffer-read-only t) (vc-exec-after `(vc-diff-sentinel ,verbose ,rev1-name ,rev2-name)) + ;; Display the buffer, but at the end because it can change point. + (pop-to-buffer (current-buffer)) ;; In the async case, we return t even if there are no differences ;; because we don't know that yet. t))) @@ -2059,11 +2074,16 @@ If `F.~REV~' already exists, use it instead of checking it out again." (with-current-buffer filebuf (vc-call find-revision file revision outbuf)))) (setq failed nil)) - (if (and failed (file-exists-p filename)) - (delete-file filename)))) + (when (and failed (file-exists-p filename)) + (delete-file filename)))) (vc-mode-line file)) (message "Checking out %s...done" filename))) - (find-file-noselect filename))) + (let ((result-buf (find-file-noselect filename))) + (with-current-buffer result-buf + ;; Set the parent buffer so that things like + ;; C-x v g, C-x v l, ... etc work. + (setq vc-parent-buffer filebuf)) + result-buf))) ;; Header-insertion code @@ -3134,11 +3154,24 @@ to provide the `find-revision' operation instead." You can use the mode-specific menu to alter the time-span of the used colors. See variable `vc-annotate-menu-elements' for customizing the menu items." + ;; Frob buffer-invisibility-spec so that if it is originally a naked t, + ;; it will become a list, to avoid initial annotations being invisible. + (add-to-invisibility-spec 'foo) + (remove-from-invisibility-spec 'foo) (set (make-local-variable 'truncate-lines) t) (set (make-local-variable 'font-lock-defaults) '(vc-annotate-font-lock-keywords t)) (view-mode 1)) +(defun vc-annotate-toggle-annotation-visibility () + "Toggle whether or not the annotation is visible." + (interactive) + (funcall (if (memq 'vc-annotate-annotation buffer-invisibility-spec) + 'remove-from-invisibility-spec + 'add-to-invisibility-spec) + 'vc-annotate-annotation) + (force-window-update (current-buffer))) + (defun vc-annotate-display-default (ratio) "Display the output of \\[vc-annotate] using the default color range. The color range is given by `vc-annotate-color-map', scaled by RATIO. @@ -3153,6 +3186,13 @@ The current time is used as the offset." ;; Since entries should be sorted, we can just use the last one. (caar (last color-map))) +(defun vc-annotate-get-time-set-line-props () + (let ((bol (point)) + (date (vc-call-backend vc-annotate-backend 'annotate-time)) + (inhibit-read-only t)) + (put-text-property bol (point) 'invisible 'vc-annotate-annotation) + date)) + (defun vc-annotate-display-autoscale (&optional full) "Highlight the output of \\[vc-annotate] using an autoscaled color map. Autoscaling means that the map is scaled from the current time to the @@ -3168,7 +3208,7 @@ cover the range from the oldest annotation to the newest." (save-excursion (goto-char (point-min)) (while (not (eobp)) - (when (setq date (vc-call-backend vc-annotate-backend 'annotate-time)) + (when (setq date (vc-annotate-get-time-set-line-props)) (if (> date newest) (setq newest date)) (if (< date oldest) @@ -3216,6 +3256,7 @@ cover the range from the oldest annotation to the newest." :style toggle :selected (eq vc-annotate-display-mode 'fullscale)] "--" + ["Toggle annotation visibility" vc-annotate-toggle-annotation-visibility] ["Annotate previous revision" vc-annotate-prev-revision] ["Annotate next revision" vc-annotate-next-revision] ["Annotate revision at line" vc-annotate-revision-at-line] @@ -3480,7 +3521,7 @@ The argument TIME is a list as returned by `current-time' or This calls the backend function annotate-time, and returns the difference in days between the time returned and the current time, or OFFSET if present." - (let ((next-time (vc-call-backend vc-annotate-backend 'annotate-time))) + (let ((next-time (vc-annotate-get-time-set-line-props))) (if next-time (- (or offset (vc-call-backend vc-annotate-backend 'annotate-current-time)) @@ -3536,7 +3577,10 @@ The annotations are relative to the current time, unless overridden by OFFSET." "Set up `log-edit' for use with VC on FILE." (setq default-directory (with-current-buffer vc-parent-buffer default-directory)) - (log-edit 'vc-finish-logentry nil `(lambda () ',fileset)) + (log-edit 'vc-finish-logentry + nil + `((log-edit-listfun . (lambda () ',fileset)) + (log-edit-diff-function . (lambda () (vc-diff nil))))) (set (make-local-variable 'vc-log-fileset) fileset) (make-local-variable 'vc-log-revision) (set-buffer-modified-p nil) diff --git a/lisp/vms-patch.el b/lisp/vms-patch.el index 39cec28d88d..82d248f2373 100644 --- a/lisp/vms-patch.el +++ b/lisp/vms-patch.el @@ -1,3 +1,4 @@ +;; -*- no-byte-compile: t -*- ;;; vms-patch.el --- override parts of files.el for VMS ;; Copyright (C) 1986, 1992, 2001, 2002, 2003, 2004, diff --git a/lisp/vmsproc.el b/lisp/vmsproc.el index 92df327dde1..136d2913975 100644 --- a/lisp/vmsproc.el +++ b/lisp/vmsproc.el @@ -1,3 +1,4 @@ +;; -*- no-byte-compile: t -*- ;;; vmsproc.el --- run asynchronous VMS subprocesses under Emacs ;; Copyright (C) 1986, 2001, 2002, 2003, 2004, 2005, diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 994eb767232..676e26ee12a 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -38,11 +38,47 @@ (defvar explicit-shell-file-name) -;; Map delete and backspace -(define-key function-key-map [backspace] "\177") -(define-key function-key-map [delete] "\C-d") -(define-key function-key-map [M-backspace] [?\M-\177]) -(define-key function-key-map [C-M-backspace] [\C-\M-delete]) +;;;; Function keys + +(defvar x-alternatives-map + (let ((map (make-sparse-keymap))) + ;; Map certain keypad keys into ASCII characters that people usually expect. + (define-key map [backspace] [127]) + (define-key map [delete] [127]) + (define-key map [tab] [?\t]) + (define-key map [linefeed] [?\n]) + (define-key map [clear] [?\C-l]) + (define-key map [return] [?\C-m]) + (define-key map [escape] [?\e]) + (define-key map [M-backspace] [?\M-\d]) + (define-key map [M-delete] [?\M-\d]) + (define-key map [M-tab] [?\M-\t]) + (define-key map [M-linefeed] [?\M-\n]) + (define-key map [M-clear] [?\M-\C-l]) + (define-key map [M-return] [?\M-\C-m]) + (define-key map [M-escape] [?\M-\e]) + (define-key map [iso-lefttab] [backtab]) + (define-key map [S-iso-lefttab] [backtab]) + map) + "Keymap of possible alternative meanings for some keys.") + +(defun x-setup-function-keys (frame) + "Set up `function-key-map' on FRAME for w32." + ;; Don't do this twice on the same display, or it would break + ;; normal-erase-is-backspace-mode. + (unless (terminal-parameter frame 'x-setup-function-keys) + ;; Map certain keypad keys into ASCII characters that people usually expect. + (with-selected-frame frame + (let ((map (copy-keymap x-alternatives-map))) + (set-keymap-parent map (keymap-parent local-function-key-map)) + (set-keymap-parent local-function-key-map map))) + (set-terminal-parameter frame 'x-setup-function-keys t))) + +(declare-function set-message-beep "w32console.c") +(declare-function w32-get-clipboard-data "w32select.c") +(declare-function w32-get-locale-info "w32proc.c") +(declare-function w32-get-valid-locale-ids "w32proc.c") +(declare-function w32-set-clipboard-data "w32select.c") ;; Ignore case on file-name completion (setq completion-ignore-case t) @@ -310,25 +346,6 @@ This function is provided for backward compatibility, since (global-set-key [lwindow] 'ignore) (global-set-key [rwindow] 'ignore) -;; Map certain keypad keys into ASCII characters -;; that people usually expect. -(define-key function-key-map [tab] [?\t]) -(define-key function-key-map [linefeed] [?\n]) -(define-key function-key-map [clear] [11]) -(define-key function-key-map [return] [13]) -(define-key function-key-map [escape] [?\e]) -(define-key function-key-map [M-tab] [?\M-\t]) -(define-key function-key-map [M-linefeed] [?\M-\n]) -(define-key function-key-map [M-clear] [?\M-\013]) -(define-key function-key-map [M-return] [?\M-\015]) -(define-key function-key-map [M-escape] [?\M-\e]) - -;; These don't do the right thing (voelker) -;(define-key function-key-map [backspace] [127]) -;(define-key function-key-map [delete] [127]) -;(define-key function-key-map [M-backspace] [?\M-\d]) -;(define-key function-key-map [M-delete] [?\M-\d]) - ;; These tell read-char how to convert ;; these special chars to ASCII. (put 'tab 'ascii-character ?\t) @@ -339,28 +356,6 @@ This function is provided for backward compatibility, since (put 'backspace 'ascii-character 127) (put 'delete 'ascii-character 127) -;; W32 uses different color indexes than standard: - -(defvar w32-tty-standard-colors - '(("black" 0 0 0 0) - ("blue" 1 0 0 52480) ; MediumBlue - ("green" 2 8704 35584 8704) ; ForestGreen - ("cyan" 3 0 52736 53504) ; DarkTurquoise - ("red" 4 45568 8704 8704) ; FireBrick - ("magenta" 5 35584 0 35584) ; DarkMagenta - ("brown" 6 40960 20992 11520) ; Sienna - ("lightgray" 7 48640 48640 48640) ; Gray - ("darkgray" 8 26112 26112 26112) ; Gray40 - ("lightblue" 9 0 0 65535) ; Blue - ("lightgreen" 10 0 65535 0) ; Green - ("lightcyan" 11 0 65535 65535) ; Cyan - ("lightred" 12 65535 0 0) ; Red - ("lightmagenta" 13 65535 0 65535) ; Magenta - ("yellow" 14 65535 65535 0) ; Yellow - ("white" 15 65535 65535 65535)) -"A list of VGA console colors, their indices and 16-bit RGB values.") - - (defun w32-add-charset-info (xlfd-charset windows-charset codepage) "Function to add character sets to display with Windows fonts. Creates entries in `w32-charset-info-alist'. diff --git a/lisp/wdired.el b/lisp/wdired.el index a76ac809feb..39d27d57848 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -556,6 +556,7 @@ If OLD, return the old target. If MOVE, move point before it." (if move (goto-char (1- beg))))) (and target (wdired-normalize-filename target)))) +(declare-function make-symbolic-link "fileio.c") ;; Perform the changes in the target of the changed links. (defun wdired-do-symlink-changes () diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index c86f8351c7a..652d49a5421 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -488,7 +488,7 @@ new value.") ;;; Widget Properties. (defsubst widget-type (widget) - "Return the type of WIDGET, a symbol." + "Return the type of WIDGET. The type is a symbol." (car widget)) ;;;###autoload @@ -1450,7 +1450,7 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-default-complete (widget) "Call the value of the :complete-function property of WIDGET. -If that does not exists, call the value of `widget-complete-field'." +If that does not exist, call the value of `widget-complete-field'." (call-interactively (or (widget-get widget :complete-function) widget-complete-field))) diff --git a/lisp/window.el b/lisp/window.el index 0f6ae8ab763..025a7c5ab65 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -215,8 +215,7 @@ to be counted) its minibuffer frame (if that's not the same frame). The optional arg MINIBUF non-nil means count the minibuffer even if it is inactive." (let ((count 0)) - (walk-windows (function (lambda (w) - (setq count (+ count 1)))) + (walk-windows (lambda (w) (setq count (+ count 1))) minibuf) count)) @@ -379,8 +378,7 @@ subtree is balanced." (h) (tried-sizes) (last-sizes) - (windows (window-list nil 0)) - (counter 0)) + (windows (window-list nil 0))) (when wt (while (not (member last-sizes tried-sizes)) (when last-sizes (setq tried-sizes (cons last-sizes tried-sizes))) @@ -415,17 +413,16 @@ Arguments WINDOW, DELTA and HORIZONTAL are passed on to that function." (when w (let ((dw (- w (- (bw-r wt) (bw-l wt))))) (when (/= 0 dw) - (bw-adjust-window wt dw t)))) + (bw-adjust-window wt dw t)))) (when h (let ((dh (- h (- (bw-b wt) (bw-t wt))))) (when (/= 0 dh) (bw-adjust-window wt dh nil))))) (let* ((childs (cdr (assq 'childs wt))) - (lastchild (car (last childs))) (cw (when w (/ w (if (bw-eqdir 'hor wt) (length childs) 1)))) (ch (when h (/ h (if (bw-eqdir 'ver wt) (length childs) 1))))) (dolist (c childs) - (bw-balance-sub c cw ch))))) + (bw-balance-sub c cw ch))))) ;;; A different solution to balance-windows @@ -561,7 +558,7 @@ window." (old-point (point)) (size (and arg (prefix-numeric-value arg))) (window-full-p nil) - new-w bottom switch moved) + new-w bottom moved) (and size (< size 0) (setq size (+ (window-height) size))) (setq new-w (split-window nil size)) (or split-window-keep-point @@ -879,6 +876,46 @@ and the buffer that is killed or buried is the one in that window." ;; Maybe get rid of the window. (and window (not window-handled) (not window-solitary) (delete-window window)))) + +(defvar recenter-last-op nil + "Indicates the last recenter operation performed. +Possible values: `top', `middle', `bottom'.") + +(defun recenter-top-bottom (&optional arg) + "Move current line to window center, top, and bottom, successively. +With a prefix argument, this is the same as `recenter': + With numeric prefix ARG, move current line to window-line ARG. + With plain `C-u', move current line to window center. + +Otherwise move current line to window center on first call, and to +top, middle, or bottom on successive calls. + +The starting position of the window determines the cycling order: + If initially in the top or middle third: top -> middle -> bottom. + If initially in the bottom third: bottom -> middle -> top. + +Top and bottom destinations are actually `scroll-conservatively' lines +from true window top and bottom." + (interactive "P") + (cond + (arg (recenter arg)) ; Always respect ARG. + ((not (eq this-command last-command)) + ;; First time - save mode and recenter. + (setq recenter-last-op 'middle) + (recenter)) + (t ;; repeat: loop through various options. + (setq recenter-last-op + (cond ((eq recenter-last-op 'middle) + (recenter scroll-conservatively) + 'top) + ((eq recenter-last-op 'top) + (recenter (1- (- scroll-conservatively))) + 'bottom) + ((eq recenter-last-op 'bottom) + (recenter) + 'middle)))))) + +(define-key global-map [?\C-l] 'recenter-top-bottom) (defvar mouse-autoselect-window-timer nil "Timer used by delayed window autoselection.") diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index f6f3b75dc07..2c36acabef4 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -117,7 +117,7 @@ any protocol specific data.") (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) - +(declare-function x-register-dnd-atom "xselect.c") (defun x-dnd-init-frame (&optional frame) "Setup drag and drop for FRAME (i.e. create appropriate properties)." @@ -422,6 +422,9 @@ otherwise return the frame coordinates." (+ frame-real-top (nth 1 edges)))) (cons frame-real-left frame-real-top)))) +(declare-function x-get-atom-name "xselect.c") +(declare-function x-send-client-message "xselect.c") + (defun x-dnd-handle-xdnd (event frame window message format data) "Receive one XDND event (client message) and send the appropriate reply. EVENT is the client message. FRAME is where the mouse is now. |