summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
authorMiles Bader <miles@gnu.org>2004-06-28 07:56:49 +0000
committerMiles Bader <miles@gnu.org>2004-06-28 07:56:49 +0000
commit327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801 (patch)
tree21de188e13b5e41a79bb50040933072ae0235217 /lisp
parent852f73b7fa7b71910282eacb6263b3ecfd4ee783 (diff)
parent376de73927383d6062483db10b8a82448505f52b (diff)
downloademacs-327719ee8a3fcdb36ed6acaf6d8cb5fbdf0bd801.tar.gz
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-15
Merge from emacs--cvs-trunk--0 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-218 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-220 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-221 Restore deleted tagline in etc/TUTORIAL.ru * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-222 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-228 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-229 Remove TeX output files from the archive * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-230 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-247 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-248 src/lisp.h (CYCLE_CHECK): Macro moved from xfaces.c * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-249 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-256 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-258 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-263 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-264 Update from CVS: lispref/display.texi: emacs -> Emacs. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-265 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-274 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-275 Update from CVS: man/makefile.w32-in: Revert last change * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-276 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-295 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-296 Allow restarting an existing debugger session that's exited * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-297 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-299 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-300 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-327 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-328 Update from CVS: src/.gdbinit (xsymbol): Fix last change. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-329 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-344 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-345 Tweak source regexps so that building in place won't cause problems * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-346 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-351 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-352 Update from CVS: lisp/flymake.el: New file. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-353 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-361 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-362 Support " [...]" style defaults in minibuffer-electric-default-mode * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-363 (read-number): Use canonical format for default in prompt. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-364 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-367 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-368 Improve display-supports-face-attributes-p on non-ttys * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-369 Rewrite face-differs-from-default-p * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-370 Move `display-supports-face-attributes-p' entirely into C code * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-371 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-372 Simplify face-differs-from-default-p; don't consider :stipple. * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-373 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-374 (tty_supports_face_attributes_p): Ensure attributes differ from default * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-375 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-376 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-377 (Fdisplay_supports_face_attributes_p): Work around bootstrapping problem * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-378 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-380 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-381 Face merging cleanups * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-382 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-384 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-385 src/xfaces.c (push_named_merge_point): Return 0 if a cycle is detected * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-386 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-395 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-396 Tweak arch tagging to make build/install-in-place less annoying * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-397 Work around vc-arch problems when building eshell * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-398 Tweak permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-399 Tweak directory permissions * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-400 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-401 More build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-402 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-403 Yet more build-in-place tweaking of arch tagging * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-404 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-409 Update from CVS * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-410 Make sure image types are initialized for lookup too * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-411 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-416 Update from CVS
Diffstat (limited to 'lisp')
-rw-r--r--lisp/.arch-inventory7
-rw-r--r--lisp/ChangeLog2799
-rw-r--r--lisp/ChangeLog.1016
-rw-r--r--lisp/Makefile.in3
-rw-r--r--lisp/abbrev.el13
-rw-r--r--lisp/add-log.el10
-rw-r--r--lisp/allout.el250
-rw-r--r--lisp/arc-mode.el8
-rw-r--r--lisp/autoinsert.el2
-rw-r--r--lisp/autorevert.el30
-rw-r--r--lisp/battery.el45
-rw-r--r--lisp/bindings.el68
-rw-r--r--lisp/bookmark.el23
-rw-r--r--lisp/calendar/appt.el9
-rw-r--r--lisp/calendar/cal-bahai.el507
-rw-r--r--lisp/calendar/cal-menu.el21
-rw-r--r--lisp/calendar/calendar.el207
-rw-r--r--lisp/calendar/diary-lib.el167
-rw-r--r--lisp/calendar/holidays.el5
-rw-r--r--lisp/calendar/time-date.el2
-rw-r--r--lisp/calendar/timeclock.el12
-rw-r--r--lisp/comint.el147
-rw-r--r--lisp/compare-w.el10
-rw-r--r--lisp/completion.el4
-rw-r--r--lisp/cus-edit.el39
-rw-r--r--lisp/cus-face.el8
-rw-r--r--lisp/custom.el13
-rw-r--r--lisp/cvs-status.el48
-rw-r--r--lisp/dabbrev.el29
-rw-r--r--lisp/delsel.el2
-rw-r--r--lisp/descr-text.el668
-rw-r--r--lisp/desktop.el300
-rw-r--r--lisp/diff-mode.el54
-rw-r--r--lisp/diff.el4
-rw-r--r--lisp/dired-aux.el196
-rw-r--r--lisp/dired-x.el82
-rw-r--r--lisp/dired.el329
-rw-r--r--lisp/dos-fns.el10
-rw-r--r--lisp/ediff.el47
-rw-r--r--lisp/ehelp.el22
-rw-r--r--lisp/emacs-lisp/autoload.el12
-rw-r--r--lisp/emacs-lisp/byte-run.el23
-rw-r--r--lisp/emacs-lisp/bytecomp.el82
-rw-r--r--lisp/emacs-lisp/checkdoc.el86
-rw-r--r--lisp/emacs-lisp/cl-indent.el8
-rw-r--r--lisp/emacs-lisp/cl-macs.el28
-rw-r--r--lisp/emacs-lisp/disass.el4
-rw-r--r--lisp/emacs-lisp/easymenu.el4
-rw-r--r--lisp/emacs-lisp/edebug.el16
-rw-r--r--lisp/emacs-lisp/ewoc.el51
-rw-r--r--lisp/emacs-lisp/find-func.el41
-rw-r--r--lisp/emacs-lisp/lisp-mode.el49
-rw-r--r--lisp/emacs-lisp/lisp.el163
-rw-r--r--lisp/emacs-lisp/pp.el56
-rw-r--r--lisp/emacs-lisp/re-builder.el2
-rw-r--r--lisp/emacs-lisp/rx.el421
-rw-r--r--lisp/emacs-lisp/timer.el13
-rw-r--r--lisp/emulation/cua-base.el181
-rw-r--r--lisp/emulation/cua-rect.el25
-rw-r--r--lisp/emulation/pc-select.el27
-rw-r--r--lisp/eshell/.arch-inventory4
-rw-r--r--lisp/eshell/.gitignore13
-rw-r--r--lisp/eshell/em-alias.el3
-rw-r--r--lisp/eshell/em-dirs.el3
-rw-r--r--lisp/eshell/em-glob.el15
-rw-r--r--lisp/eshell/em-hist.el1
-rw-r--r--lisp/eshell/em-unix.el3
-rw-r--r--lisp/eshell/esh-cmd.el5
-rw-r--r--lisp/eshell/esh-io.el46
-rw-r--r--lisp/eshell/esh-module.el53
-rw-r--r--lisp/eshell/esh-test.el8
-rw-r--r--lisp/facemenu.el28
-rw-r--r--lisp/faces.el69
-rw-r--r--lisp/ffap.el2
-rw-r--r--lisp/files.el175
-rw-r--r--lisp/find-dired.el17
-rw-r--r--lisp/follow.el2
-rw-r--r--lisp/font-lock.el18
-rw-r--r--lisp/format.el12
-rw-r--r--lisp/frame.el15
-rw-r--r--lisp/generic.el5
-rw-r--r--lisp/gnus/ChangeLog20
-rw-r--r--lisp/gnus/gnus-win.el4
-rw-r--r--lisp/gnus/mailcap.el1
-rw-r--r--lisp/gnus/mm-view.el5
-rw-r--r--lisp/gnus/nnimap.el14
-rw-r--r--lisp/gnus/rfc2047.el4
-rw-r--r--lisp/gnus/starttls.el234
-rw-r--r--lisp/gs.el7
-rw-r--r--lisp/help-fns.el258
-rw-r--r--lisp/help-mode.el37
-rw-r--r--lisp/help.el68
-rw-r--r--lisp/hexl.el6
-rw-r--r--lisp/ibuf-ext.el69
-rw-r--r--lisp/ibuf-macs.el16
-rw-r--r--lisp/ibuffer.el8
-rw-r--r--lisp/ido.el22
-rw-r--r--lisp/ielm.el107
-rw-r--r--lisp/iimage.el134
-rw-r--r--lisp/image.el61
-rw-r--r--lisp/imenu.el4
-rw-r--r--lisp/info-look.el29
-rw-r--r--lisp/info.el628
-rw-r--r--lisp/international/ccl.el3
-rw-r--r--lisp/international/mule-cmds.el30
-rw-r--r--lisp/international/mule-diag.el4
-rw-r--r--lisp/international/mule-util.el22
-rw-r--r--lisp/international/mule.el12
-rw-r--r--lisp/international/quail.el179
-rw-r--r--lisp/international/titdic-cnv.el30
-rw-r--r--lisp/isearch.el49
-rw-r--r--lisp/isearchb.el227
-rw-r--r--lisp/iswitchb.el177
-rw-r--r--lisp/language/chinese.el2
-rw-r--r--lisp/language/european.el40
-rw-r--r--lisp/language/japanese.el1
-rw-r--r--lisp/language/korean.el1
-rw-r--r--lisp/ldefs-boot.el18
-rw-r--r--lisp/locate.el186
-rw-r--r--lisp/log-view.el6
-rw-r--r--lisp/mail/rfc2368.el3
-rw-r--r--lisp/mail/rmail.el43
-rw-r--r--lisp/mail/sendmail.el7
-rw-r--r--lisp/mail/smtpmail.el9
-rw-r--r--lisp/mail/unrmail.el189
-rw-r--r--lisp/makefile.nt284
-rw-r--r--lisp/makefile.w32-in46
-rw-r--r--lisp/man.el7
-rw-r--r--lisp/menu-bar.el5
-rw-r--r--lisp/mh-e/ChangeLog12
-rw-r--r--lisp/mh-e/mh-e.el13
-rw-r--r--lisp/minibuf-eldef.el6
-rw-r--r--lisp/mouse.el18
-rw-r--r--lisp/net/ange-ftp.el7
-rw-r--r--lisp/net/browse-url.el31
-rw-r--r--lisp/net/ldap.el2
-rw-r--r--lisp/net/quickurl.el16
-rw-r--r--lisp/net/telnet.el37
-rw-r--r--lisp/net/tramp-smb.el18
-rw-r--r--lisp/net/tramp-uu.el10
-rw-r--r--lisp/net/tramp-vc.el41
-rw-r--r--lisp/net/tramp.el481
-rw-r--r--lisp/newcomment.el26
-rw-r--r--lisp/outline.el22
-rw-r--r--lisp/paren.el5
-rw-r--r--lisp/pcomplete.el45
-rw-r--r--lisp/pcvs-defs.el1
-rw-r--r--lisp/pcvs-util.el19
-rw-r--r--lisp/pcvs.el17
-rw-r--r--lisp/progmodes/ada-mode.el16
-rw-r--r--lisp/progmodes/cc-cmds.el2
-rw-r--r--lisp/progmodes/cfengine.el7
-rw-r--r--lisp/progmodes/compile.el619
-rw-r--r--lisp/progmodes/cperl-mode.el9
-rw-r--r--lisp/progmodes/etags.el19
-rw-r--r--lisp/progmodes/f90.el60
-rw-r--r--lisp/progmodes/flymake.el2504
-rw-r--r--lisp/progmodes/fortran.el3
-rw-r--r--lisp/progmodes/gdb-ui.el520
-rw-r--r--lisp/progmodes/grep.el4
-rw-r--r--lisp/progmodes/gud.el95
-rw-r--r--lisp/progmodes/idlw-shell.el4
-rw-r--r--lisp/progmodes/python.el569
-rw-r--r--lisp/progmodes/sh-script.el2
-rw-r--r--lisp/progmodes/sql.el941
-rw-r--r--lisp/ps-print.el37
-rw-r--r--lisp/recentf.el17
-rw-r--r--lisp/replace.el137
-rw-r--r--lisp/saveplace.el4
-rw-r--r--lisp/sb-dir-minus.xpm37
-rw-r--r--lisp/sb-dir-plus.xpm37
-rw-r--r--lisp/sb-dir.xpm35
-rw-r--r--lisp/sb-mail.xpm37
-rw-r--r--lisp/sb-pg-minus.xpm37
-rw-r--r--lisp/sb-pg-plus.xpm37
-rw-r--r--lisp/sb-pg.xpm37
-rw-r--r--lisp/sb-tag-gt.xpm29
-rw-r--r--lisp/sb-tag-minus.xpm31
-rw-r--r--lisp/sb-tag-plus.xpm31
-rw-r--r--lisp/sb-tag-type.xpm29
-rw-r--r--lisp/sb-tag-v.xpm29
-rw-r--r--lisp/sb-tag.xpm29
-rw-r--r--lisp/select.el83
-rw-r--r--lisp/ses.el2
-rw-r--r--lisp/simple.el304
-rw-r--r--lisp/smerge-mode.el23
-rw-r--r--lisp/startup.el4
-rw-r--r--lisp/subr.el204
-rw-r--r--lisp/term/w32-win.el18
-rw-r--r--lisp/term/x-win.el5
-rw-r--r--lisp/textmodes/artist.el45
-rw-r--r--lisp/textmodes/bibtex.el566
-rw-r--r--lisp/textmodes/fill.el10
-rw-r--r--lisp/textmodes/flyspell.el139
-rw-r--r--lisp/textmodes/ispell.el9
-rw-r--r--lisp/textmodes/paragraphs.el62
-rw-r--r--lisp/textmodes/picture.el10
-rw-r--r--lisp/textmodes/table.el17
-rw-r--r--lisp/textmodes/tex-mode.el31
-rw-r--r--lisp/textmodes/texinfmt.el4
-rw-r--r--lisp/thumbs.el338
-rw-r--r--lisp/time-stamp.el8
-rw-r--r--lisp/toolbar/README8
-rw-r--r--lisp/toolbar/alias.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/close.pbmbin81 -> 199 bytes
-rw-r--r--lisp/toolbar/close.xpm57
-rw-r--r--lisp/toolbar/copy.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/copy.xpm88
-rw-r--r--lisp/toolbar/cut.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/cut.xpm97
-rw-r--r--lisp/toolbar/help.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/help.xpm305
-rw-r--r--lisp/toolbar/home.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/home.xpm160
-rw-r--r--lisp/toolbar/index.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/index.xpm238
-rw-r--r--lisp/toolbar/jump_to.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/jump_to.xpm208
-rw-r--r--lisp/toolbar/lc-copy.xpm33
-rw-r--r--lisp/toolbar/lc-cut.xpm34
-rw-r--r--lisp/toolbar/lc-help.xpm39
-rw-r--r--lisp/toolbar/lc-home.xpm38
-rw-r--r--lisp/toolbar/lc-index.xpm34
-rw-r--r--lisp/toolbar/lc-jump_to.xpm35
-rw-r--r--lisp/toolbar/lc-left_arrow.xpm34
-rw-r--r--lisp/toolbar/lc-new.xpm33
-rw-r--r--lisp/toolbar/lc-open.xpm35
-rw-r--r--lisp/toolbar/lc-paste.xpm35
-rw-r--r--lisp/toolbar/lc-preferences.xpm37
-rw-r--r--lisp/toolbar/lc-print.xpm33
-rw-r--r--lisp/toolbar/lc-right_arrow.xpm33
-rw-r--r--lisp/toolbar/lc-save.xpm39
-rw-r--r--lisp/toolbar/lc-saveas.xpm40
-rw-r--r--lisp/toolbar/lc-search.xpm33
-rw-r--r--lisp/toolbar/lc-spell.xpm35
-rw-r--r--lisp/toolbar/lc-undo.xpm32
-rw-r--r--lisp/toolbar/lc-up_arrow.xpm35
-rw-r--r--lisp/toolbar/left_arrow.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/left_arrow.xpm86
-rw-r--r--lisp/toolbar/new.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/new.xpm189
-rw-r--r--lisp/toolbar/open.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/open.xpm232
-rw-r--r--lisp/toolbar/paste.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/paste.xpm149
-rw-r--r--lisp/toolbar/preferences.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/preferences.xpm139
-rw-r--r--lisp/toolbar/print.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/print.xpm236
-rw-r--r--lisp/toolbar/right_arrow.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/right_arrow.xpm84
-rw-r--r--lisp/toolbar/save.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/save.xpm280
-rw-r--r--lisp/toolbar/saveas.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/saveas.xpm322
-rw-r--r--lisp/toolbar/search.pbmbin634 -> 185 bytes
-rw-r--r--lisp/toolbar/search.xpm270
-rw-r--r--lisp/toolbar/spell.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/spell.xpm97
-rw-r--r--lisp/toolbar/tool-bar.el52
-rw-r--r--lisp/toolbar/undo.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/undo.xpm91
-rw-r--r--lisp/toolbar/up_arrow.pbmbin81 -> 185 bytes
-rw-r--r--lisp/toolbar/up_arrow.xpm108
-rw-r--r--lisp/tree-widget.el736
-rw-r--r--lisp/type-break.el372
-rw-r--r--lisp/url/url-dav.el983
-rw-r--r--lisp/url/url-file.el245
-rw-r--r--lisp/url/url-handlers.el258
-rw-r--r--lisp/url/url-http.el1224
-rw-r--r--lisp/url/url-https.el56
-rw-r--r--lisp/url/url-nfs.el100
-rw-r--r--lisp/url/url-util.el508
-rw-r--r--lisp/vc-arch.el6
-rw-r--r--lisp/vc-hooks.el10
-rw-r--r--lisp/vc-mcvs.el10
-rw-r--r--lisp/vc-svn.el20
-rw-r--r--lisp/vc.el8
-rw-r--r--lisp/version.el2
-rw-r--r--lisp/view.el1
-rw-r--r--lisp/w32-fns.el21
-rw-r--r--lisp/wdired.el873
-rw-r--r--lisp/wid-edit.el17
-rw-r--r--lisp/window.el8
-rw-r--r--lisp/winner.el10
-rw-r--r--lisp/woman.el104
-rw-r--r--lisp/x-dnd.el18
-rw-r--r--lisp/xml.el86
288 files changed, 23467 insertions, 6406 deletions
diff --git a/lisp/.arch-inventory b/lisp/.arch-inventory
new file mode 100644
index 00000000000..9bd88350a95
--- /dev/null
+++ b/lisp/.arch-inventory
@@ -0,0 +1,7 @@
+# Auto-generated lisp files, which ignore
+precious ^(loaddefs|finder-inf|cus-load)\.el$
+
+# Something generated during a windows build?!?
+precious ^(Makefile\.unix)$
+
+# arch-tag: fc62dc9f-3a91-455b-b8e7-d49df66beee0
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8571f7edd19..70f7255782a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,2714 @@
+2004-06-20 Richard M. Stallman <rms@gnu.org>
+
+ * mouse.el (mouse-set-region-1): Set transient-mark-mode to `only'.
+
+ * isearch.el (isearch-repeat): Avoid testing old match data.
+ (isearch-message): Display trailing space in special font
+ when search is failing.
+ (isearch-search-fun-function): Doc fix.
+
+ * autorevert.el (global-auto-revert-non-file-buffers): Doc fix.
+
+2004-06-19 Luc Teirlinck <teirllm@auburn.edu>
+
+ * frame.el (show-trailing-whitespace): Doc fix.
+
+ * cus-edit.el (custom-variable-documentation): New function.
+ (custom-variable): Use it.
+
+2004-06-19 Nick Roberts <nickrob@gnu.org>
+
+ * man.el (Man-getpage-in-background): Revert previous change but
+ make cygwin a special case.
+
+2004-06-18 Luc Teirlinck <teirllm@auburn.edu>
+
+ * autorevert.el (global-auto-revert-non-file-buffers): Update
+ docstring.
+
+2004-06-19 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compilation-error-properties): Store one
+ more than end-col, if present, so that transient-mark-mode will
+ highlight last char too.
+ * progmodes/grep.el (grep-regexp-alist): Match columns and column
+ ranges, if present.
+
+2004-06-18 Jason Rumney <jasonr@gnu.org>
+
+ * makefile.w32-in: Double percent signs in for loops.
+
+2004-06-17 David Kastrup <dak@gnu.org>
+
+ * replace.el (query-replace-read-args): Only warn about use of \n
+ and \t when we are doing a regexp replacement and the actual
+ escaped character is n or t.
+ (query-replace-regexp): Add \, and \# interpretation to
+ interactive call and document it.
+ (query-replace-regexp-eval, replace-match-string-symbols): add \#
+ as shortkey for replace-count.
+ (replace-quote): New function for doubling backslashes.
+
+2004-06-17 Juanma Barranquero <lektu@terra.es>
+
+ * files.el (parse-colon-path, cd): Mention in docstring that the
+ path separator is colon in GNU-like systems.
+
+ * newcomment.el (comment-region-internal): Fix docstring.
+
+ * emacs-lisp/ewoc.el (ewoc-create, ewoc-map, ewoc-locate)
+ (ewoc-invalidate, ewoc-collect): Doc fixes.
+ (ewoc--create-node, ewoc--delete-node-internal):
+ Fix typos in docstring.
+
+2004-06-15 Luc Teirlinck <teirllm@auburn.edu>
+
+ * files.el (buffer-stale-function): Add hyperlink to emacs-xtra
+ manual to docstring.
+
+2004-06-15 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * ps-print.el (ps-time-stamp-iso8601): Comment doc string of defalias.
+
+2004-06-15 Luc Teirlinck <teirllm@auburn.edu>
+
+ * dired-aux.el (dired-do-redisplay, dired-maybe-insert-subdir):
+ Add hyperlink to emacs-xtra manual to docstring.
+
+ * autorevert.el (global-auto-revert-non-file-buffers): Add
+ hyperlink to emacs-xtra manual to docstring, as well as an
+ info-link.
+
+2004-06-14 Juanma Barranquero <lektu@terra.es>
+
+ * image.el (image-library-alist): New variable to map image types
+ to external libraries. Initialized to nil, unless system-specific
+ configs change it.
+ (image-type-available-p): Determine whether an image type is
+ available by calling `init-image-library'.
+
+ * term/w32-win.el (image-library-alist): Initialize to a known set
+ of probable library names.
+
+2004-06-14 Kenichi Handa <handa@m17n.org>
+
+ * international/code-pages.el (windows-1256, cp1125): Fix tables
+ for several characters.
+
+ * international/utf-8.el (ccl-encode-mule-utf-8): Fix previous
+ change.
+
+2004-06-13 Richard M. Stallman <rms@gnu.org>
+
+ * textmodes/paragraphs.el (sentence-end): Add 0x5397d as close brace.
+
+ * emulation/pc-select.el: Doc fixes: say "PC Selection mode",
+ not "`pc-selection-mode'".
+
+ * emacs-lisp/bytecomp.el: Put `...' around symbols in warning messages.
+
+ * simple.el (previous-matching-history-element): Specify a default.
+
+ * hexl.el (hexl-mode): Catch errors in hexl-goto-address.
+
+ * cus-face.el (custom-declare-face): Simplify code.
+
+ * abbrev.el (abbrev-mode, edit-abbrevs-map): Doc fixes.
+
+2004-06-13 Luc Teirlinck <teirllm@auburn.edu>
+
+ * files.el (before-save-hook): Add `time-stamp' to the options.
+
+ * time-stamp.el (time-stamp): Recommend adding it to
+ `before-save-hook', rather than `write-file-functions'.
+ Make a similar change in `Commentary' section.
+
+2004-06-13 Kai Grossjohann <kai.grossjohann@gmx.net>
+
+ * diff-mode.el (diff-current-defun): If at start of hunk, use
+ position of first change.
+
+2004-06-13 Lars Hansen <larsh@math.ku.dk>
+
+ * dired-x.el (dired-mark-omitted): Bind to "*O".
+
+2004-06-12 Karl Fogel <kfogel@red-bean.com>
+
+ * bookmark.el (bookmark-bmenu-relocate): New function, as
+ suggested by David J. Biesack <David.Biesack@sas.com>.
+ (bookmark-bmenu-mode-map): Bind `bookmark-bmenu-relocate' to "R".
+ (bookmark-bmenu-mode): Describe binding in doc string.
+ (bookmark-set-filename): Save the bookmark list if it's time.
+
+2004-06-13 Kenichi Handa <handa@m17n.org>
+
+ * international/utf-8.el (ccl-decode-mule-utf-8): Fix previous
+ change.
+ (ccl-untranslated-to-ucs): Fix typo.
+
+2004-06-12 Karl Chen <quarl@hkn.eecs.berkeley.edu> (tiny change)
+
+ * progmodes/python.el (python-open-block-statement-p): Fix
+ indentation after a block opening that contains a comment.
+
+2004-06-12 J,Ai(Br,At(Bme Marant <jerome@marant.org> (tiny change)
+
+ * bindings.el (completion-ignored-extensions): Add file extensions
+ of Python byte-compiled files.
+
+2004-06-12 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-goto-node): Add autoload.
+ (Info-toc): Add substring-no-properties on Info file name.
+ (Info-mode, info, Info-toc, Info-mode-menu): Doc fix.
+ (Info-mode-map): Bind L to Info-history, T to Info-toc.
+
+2004-06-12 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-cmds.el (set-language-environment): Load
+ subst tables if necessary.
+
+ * international/mule.el (decode-char): Load subst tables if
+ necessary.
+ (encode-char): Likewise.
+
+ * international/utf-16.el (utf-16-decode-ucs): Handle a surrogate
+ pair correctly. Call ccl-mule-utf-untrans for untranslable chars.
+ (utf-16le-decode-loop): Set r5 to -1 before loop.
+ (utf-16be-decode-loop): Likewise.
+ (ccl-decode-mule-utf-16le): Add EOF processing block.
+ (ccl-decode-mule-utf-16be): Likewise.
+ (ccl-decode-mule-utf-16le-with-signature): Likewise.
+ (ccl-decode-mule-utf-16be-with-signature): Likewise.
+ (ccl-decode-mule-utf-16): Likewise. Set r5 to -1 initially.
+ (ccl-mule-utf-16-encode-untrans): New CCL.
+ (utf-16-decode-to-ucs): Handle pre-read character.
+ (utf-16le-encode-loop): Handle surrogate pair.
+ (utf-16be-encode-loop): Likewise.
+ (ccl-encode-mule-utf-16le-with-signature): Adjusted for the change
+ of utf-16le-encode-loop.
+ (ccl-encode-mule-utf-16be-with-signature): Adjusted for the change
+ of utf-16be-encode-loop.
+ (mule-utf-16-post-read-conversion): Call
+ utf-8-post-read-conversion at first.
+ (mule-utf-16[{le|be}], mule-utf-16{le|be}-with-signature): Include
+ CJK charsets in safe-charsets if utf-translate-cjk-mode is on.
+ Add post-read-conversion and pre-write-conversion.
+
+ * international/utf-8.el (utf-translate-cjk-charsets): New
+ variable.
+ (utf-translate-cjk-unicode-range): New variable.
+ (utf-translate-cjk-load-tables): New function.
+ (utf-lookup-subst-table-for-decode): New function.
+ (utf-lookup-subst-table-for-encode): New function.
+ (utf-translate-cjk-mode): Init-value changed to t. Don't load
+ tables here. Update safe-charsets of utf-* coding systems.
+ (ccl-mule-utf-untrans): New CCL.
+ (ccl-decode-mule-utf-8): Call ccl-mule-utf-untrans. Use `repeat'
+ at end of each branch.
+ (ccl-mule-utf-8-encode-untrans): New CCL.
+ (ccl-encode-mule-utf-8): Call ccl-mule-utf-8-encode-untrans.
+ (ccl-untranslated-to-ucs): Handle 2-byte encoding. Set r1 to the
+ length of encoding. Don't return r0.
+ (utf-8-compose): New arg hash-table. Handle 2-byte encoding.
+ (utf-8-post-read-conversion): Narrow to region properly. If
+ utf-translate-cjk-mode is on, load tables if necessary. Call
+ utf-8-compose with hash-table arg if necessary. Call
+ XXX-compose-region instead of XXX-post-read-convesion.
+ (utf-8-pre-write-conversion): New function.
+ (mule-utf-8): Include CJK charsets in safe-charsets if
+ utf-translate-cjk-mode is on. Add pre-write-conversion.
+
+ * international/characters.el: Temporarily set
+ utf-translate-cjk-mode to nil.
+
+ * language/devan-util.el (devanagari-compose-region): Add
+ autoload cookie.
+
+ * international/ccl.el (ccl-dump-call): Fix printing the
+ subroutine name.
+
+2004-06-11 Luc Teirlinck <teirllm@auburn.edu>
+
+ * dired.el (dired-revert): If buffer is marked unmodified before
+ reverting, keep it marked unmodified.
+ Adapt to new conventions for commenting out code.
+ (dired-make-relative): Adapt to new conventions for commenting out
+ code.
+
+2004-06-10 Miles Bader <miles@gnu.ai.mit.edu>
+
+ * eshell/esh-module.el (eshell-load-defgroups): Bind
+ `vc-handled-backends' to nil when opening files.
+
+2004-06-11 Juanma Barranquero <lektu@terra.es>
+
+ * files.el (parse-colon-path, cd): Doc fixes (refer to
+ `path-separator', not colon).
+
+2004-06-10 Juanma Barranquero <lektu@terra.es>
+
+ * newcomment.el (comment-search-forward)
+ (comment-search-backward): Fix typos in docstring.
+ (comment-region): Doc fix.
+
+2004-06-10 Luc Teirlinck <teirllm@auburn.edu>
+
+ * dired.el (dired-insert-old-subdirs): Adapt to fact that the R
+ switch is no longer stored in `dired-switches-alist'.
+
+ * dired-aux.el (dired-insert-subdir): Do not store R switch in
+ `dired-switches-alist'.
+
+2004-06-10 Kim F. Storm <storm@cua.dk>
+
+ * pcvs.el (cvs-mode-diff-yesterday): New command.
+
+ * pcvs-defs.el (cvs-mode-diff-map): Bind y to cvs-mode-diff-yesterday.
+
+2004-06-10 Juri Linkov <juri@jurta.org>
+
+ * emacs-lisp/edebug.el (edebug-eval-defun):
+ * emacs-lisp/lisp-mode.el (eval-defun-1): Add `defface'.
+ Fix docstring.
+
+ * simple.el (eval-expression-print-format): Don't print additional
+ information on the first call to `eval-print-last-sexp'.
+ (next-error-find-buffer): Fix punctuation.
+ (killing) <defgroup>: Fix punctuation.
+ (yank-excluded-properties): Change group from editing to killing.
+
+ * replace.el (perform-replace): Use `limit' to terminate the
+ while-loop explicitly.
+
+2004-06-09 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * toolbar/tool-bar.el (tool-bar-add-item, tool-bar-local-item):
+ Use lc-*.xpm as prefix instead of *-locol.xpm.
+
+ * toolbar/lc-copy.xpm, toolbar/lc-cut.xpm
+ * toolbar/lc-help.xpm, toolbar/lc-home.xpm
+ * toolbar/lc-index.xpm, toolbar/lc-jump_to.xpm
+ * toolbar/lc-left_arrow.xpm, toolbar/lc-new.xpm
+ * toolbar/lc-open.xpm, toolbar/lc-paste.xpm
+ * toolbar/lc-preferences.xpm, toolbar/lc-print.xpm
+ * toolbar/lc-right_arrow.xpm, toolbar/lc-save.xpm
+ * toolbar/lc-saveas.xpm, toolbar/lc-search.xpm
+ * toolbar/lc-spell.xpm, toolbar/lc-undo.xpm
+ * toolbar/lc-up_arrow.xpm:
+ Renamed from *-locol.xpm.
+
+2004-06-09 Rajesh Vaidheeswarran <rv@gnu.org>
+
+ * ffap.el (ffap-string-at-point-mode-alist): Fix the url mode to
+ include forms like &<str>; as valid url patterns.
+
+2004-06-08 Luc Teirlinck <teirllm@auburn.edu>
+
+ * dired.el (dired-diff, dired-backup-diff)
+ (dired-clean-directory, dired-do-chmod, dired-do-chgrp)
+ (dired-do-chown, dired-do-touch, dired-do-print)
+ (dired-do-shell-command, dired-do-kill-lines, dired-do-compress)
+ (dired-do-byte-compile, dired-do-load, dired-do-redisplay)
+ (dired-create-directory, dired-do-copy, dired-do-symlink)
+ (dired-do-hardlink, dired-do-rename, dired-do-rename-regexp)
+ (dired-do-copy-regexp, dired-do-hardlink-regexp)
+ (dired-do-symlink-regexp, dired-upcase, dired-downcase)
+ (dired-maybe-insert-subdir, dired-next-subdir)
+ (dired-prev-subdir, dired-goto-subdir, dired-mark-subdir-files)
+ (dired-kill-subdir, dired-tree-up, dired-tree-down)
+ (dired-hide-subdir, dired-hide-all, dired-show-file-type)
+ (dired-run-shell-command, dired-query): Remove redundant,
+ or incorrect, autoloads.
+
+ * dired-aux.el (dired-kill-tree): Do not kill DIRNAME, even if it
+ does not end in a slash. Add optional argument KILL-ROOT. Update
+ docstring.
+ (dired-do-touch, dired-clean-directory, dired-run-shell-command)
+ (dired-query): Add autoloads.
+
+2004-06-08 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compilation-set-window-height): Rearrange
+ the save-* functions because a buffer can have several current
+ point in different windows.
+ (compilation-error-regexp-alist-alist): Recognize {standard input}
+ GNU messages (for gcc --pipe) and more kinds of Oracle messages.
+
+2004-06-08 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * toolbar/copy-locol.xpm, toolbar/cut-locol.xpm
+ * toolbar/help-locol.xpm, toolbar/home-locol.xpm
+ * toolbar/index-locol.xpm, toolbar/jump_to-locol.xpm
+ * toolbar/left_arrow-locol.xpm, toolbar/new-locol.xpm
+ * toolbar/open-locol.xpm, toolbar/paste-locol.xpm
+ * toolbar/preferences-locol.xpm, toolbar/print-locol.xpm
+ * toolbar/right_arrow-locol.xpm, toolbar/save-locol.xpm
+ * toolbar/saveas-locol.xpm, toolbar/search-locol.xpm
+ * toolbar/spell-locol.xpm, toolbar/undo-locol.xpm
+ * toolbar/up_arrow-locol.xpm:
+ New versions of icons that uses fewer colors.
+
+ * toolbar/tool-bar.el (tool-bar-local-item)
+ (tool-bar-local-item-from-menu): Try to use icons with fewer colors
+ if display-color-cells is 256 or less.
+
+2004-06-08 Kim F. Storm <storm@cua.dk>
+
+ * wid-edit.el (widget-specify-button): Use hand pointer rather
+ than mouse-face as visible mouse-over effect.
+
+2004-06-07 Karl Fogel <kfogel@red-bean.com>
+
+ * saveplace.el (save-place-alist-to-file): Bind `print-length'
+ and `print-level' to nil when writing out `save-place-alist'.
+ Thanks to Kai Grossjohann <kai@emptydomain.de> for enlightenment.
+
+2004-06-07 Juanma Barranquero <lektu@terra.es>
+
+ * completion.el (completion-kill-region): Doc fix.
+
+ * format.el (format-insert-annotations)
+ (format-annotate-location): Doc fixes.
+ (format-subtract-regions): Make arguments match their use in
+ docstring.
+
+ * simple.el (kill-region): Doc fix.
+
+ * subr.el (insert-buffer-substring-no-properties)
+ (insert-buffer-substring-as-yank): Doc fixes.
+
+2004-06-07 Luc Teirlinck <teirllm@auburn.edu>
+
+ * dired-aux.el (dired-do-redisplay, dired-maybe-insert-subdir):
+ Update docstring.
+ (dired-reset-subdir-switches): New function.
+
+ * dired.el (dired-undo): Call `dired-build-subdir-alist'.
+ Limit scope of `buffer-read-only' binding.
+
+2004-06-06 Emilio C. Lopes <eclig@gmx.net>
+
+ * eshell/esh-cmd.el (eshell/which): Respect commands quoted with
+ eshell-explicit-command-char.
+
+2004-06-06 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-argument-name): Inherit from italic face only
+ if the frame supports it.
+
+2004-06-06 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * toolbar/alias.pbm, toolbar/close.pbm, toolbar/copy.pbm
+ * toolbar/cut.pbm, toolbar/help.pbm, toolbar/home.pbm
+ * toolbar/index.pbm, toolbar/jump_to.pbm, toolbar/left_arrow.pbm
+ * toolbar/new.pbm, toolbar/open.pbm, toolbar/paste.pbm
+ * toolbar/preferences.pbm, toolbar/print.pbm, toolbar/right_arrow.pbm
+ * toolbar/save.pbm, toolbar/saveas.pbm, toolbar/search.pbm
+ * toolbar/spell.pbm, toolbar/undo.pbm, toolbar/up_arrow.pbm:
+ New conversions from xpm files.
+
+ * toolbar/README: New file.
+
+2004-06-06 Richard M. Stallman <rms@gnu.org>
+
+ * isearch.el (isearch-mode-map): Undo previous change.
+
+2004-06-05 Juri Linkov <juri@jurta.org>
+
+ * bindings.el (debug-ignored-errors): Add regexps for history
+ related messages. Remove $ from "No further undo information".
+ Move Ediff's messages to ediff.el.
+
+ * ediff.el: Move Ediff's debug-ignored-errors from bindings.el.
+
+ * cus-edit.el (custom-display): Add `min-colors'.
+
+ * custom.el (defface): Add `supports' to docstring.
+
+ * help-fns.el (help-argument-name): Add :group 'help.
+
+2004-06-05 Luc Teirlinck <teirllm@auburn.edu>
+
+ * find-dired.el (find-ls-subdir-switches): New user option.
+ (find-dired): No longer call `abbreviate-file-name' on DIR.
+ Set `dired-subdir-switches' buffer-locally.
+
+ * locate.el: Merge the two `Commentary' sections.
+ (locate-ls-subdir-switches): New user option.
+ (locate): Update for other changes.
+ (locate-mode-map): Restore Dired binding for mouse-2.
+ Bind `locate-mouse-view-file' to M-mouse-2.
+ Bind `l' to `locate-do-redisplay'.
+ (locate-main-listing-line-p, locate-do-redisplay): New functions.
+ (locate-mouse-view-file, locate-tags, locate-find-directory):
+ Print message if used outside main listing.
+ (locate-mode): Update docstring. Make `*Locate*' buffer read-only.
+ Various changes to support inserted subdirectories.
+ (locate-insert-header): Change header of *Locate* buffer.
+
+ * dired-aux.el (dired-do-redisplay, dired-maybe-insert-subdir):
+ Change interactive default switches.
+ (dired-rename-subdir-2): Update `dired-switches-alist'.
+ (dired-insert-subdir, dired-kill-subdir):
+ Handle `dired-switches-alist'. Do not mark buffer modified.
+ (dired-insert-subdir-validate): Handle `dired-subdir-switches'.
+ (dired-insert-subdir-doinsert): Omit messages.
+ Handle `dired-subdir-switches'.
+ (dired-hide-subdir, dired-hide-all): Do not mark buffer modified.
+
+ * dired.el (dired-subdir-switches, dired-switches-alist):
+ New vars.
+ (dired-insert-old-subdirs): Do not repeatedly delete and reinsert
+ subdirs if -R switch is used for a subdir.
+ (dired-mode): Set `dired-switches-alist'.
+ (dired-build-subdir-alist): Only print number of directories in
+ echo area when invoked interactively.
+
+2004-06-05 Lars Hansen <larsh@math.ku.dk>
+
+ * dired-x.el (dired-omit-mode): Rename from
+ dired-omit-files-p. Use define-minor-mode to define it.
+ (dired-omit-files-p): Add as alias for dired-omit-mode.
+ (dired-omit-toggle): Delete. Replaced by dired-omit-mode and
+ dired-mark-omitted.
+ (dired-mark-omitted): Add. Bind to M-O.
+
+2004-06-05 Kenichi Handa <handa@m17n.org>
+
+ * ps-print.el: Fix typos (kein'ichi -> ken'ichi)
+
+2004-06-05 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-argument-name): Reintroduce face.
+ (help-default-arg-highlight): Use it, now that
+ `face-differs-from-default-p' can be trusted.
+
+2004-06-05 Matt Hodges <matt@stchem.bham.ac.uk> (tiny change)
+
+ * textmodes/table.el: Sentence commands added to Point Motion
+ group; kill and backward-kill commands added to Extraction group.
+
+2004-06-04 Mario Lang <mlang@delysid.org>
+
+ * battery.el (battery-linux-proc-acpi): mA was hardcored, but some
+ systems appear to use mW, make the code handle this. Fix a
+ division-by-zero bug while at it, and handle kernels with
+ a slightly different layout in /proc/acpi.
+
+2004-06-04 Karl Fogel <kfogel@red-bean.com>
+
+ * vc-svn.el (vc-svn-checkin): Use 'nconc' instead of 'list*',
+ because the latter is a CL-ism. This fixes the bug reported by
+ Shawn Boyette <mdxi@collapsar.net> in
+ http://lists.gnu.org/archive/html/emacs-devel/2004-05/msg00442.html.
+
+2004-06-04 Miles Bader <miles@gnu.org>
+
+ * faces.el (display-supports-face-attributes-p): Function moved to
+ C code. Previously only the tty-related portion of this function
+ was done in C; however the previous attempt to do a halfway-proper
+ job for non-tty displays in lisp didn't work properly because of
+ funny conditions during Emacs startup.
+ (face-differs-from-default-p): Simplify, now that
+ display-supports-face-attributes-p works properly on all display
+ types. Remove :stipple from comparison; it doesn't really work
+ in emacs anyway.
+
+2004-06-04 Miles Bader <miles@gnu.org>
+
+ * faces.el (face-differs-from-default-p): Use a different
+ implementation, so we can really check whether FACE displays
+ differently or not.
+
+2004-06-04 Miles Bader <miles@gnu.org>
+
+ * faces.el (display-supports-face-attributes-p): Implement a
+ `different from default' check for non-tty displays.
+
+2004-06-03 David Kastrup <dak@gnu.org>
+
+ * woman.el (woman-mapcan): More concise code.
+ (woman-topic-all-completions, woman-topic-all-completions-1)
+ (woman-topic-all-completions-merge): Replace by a simpler and
+ much faster implementation based on O(n log n) sort/merge instead
+ of the old O(n^2) behavior.
+
+2004-06-03 Miles Bader <miles@gnu.org>
+
+ * subr.el (read-number): Use canonical format for default in prompt.
+
+ * minibuf-eldef.el (minibuffer-default-in-prompt-regexps): Add
+ regexp for " [...]" style defaults.
+
+2004-06-02 Romain Francoise <romain@orebokech.com>
+
+ * ibuf-ext.el (ibuffer-jump-to-buffer): Add support for filter
+ groups: if the user asks for a hidden buffer, open the
+ corresponding filter group to expose it.
+
+ * ibuffer.el (ibuffer-mode-map): Add key binding `M-g' to
+ `ibuffer-jump-to-buffer'.
+ (ibuffer-jump-offer-only-visible-buffers): New user option.
+
+2004-06-02 Juanma Barranquero <lektu@terra.es>
+
+ * faces.el (frame-update-faces): Add empty docstring so the one
+ for `ignore' doesn't show through.
+
+ * subr.el (process-kill-without-query): Remove spurious "\n" on
+ obsolescence string.
+ (focus-frame, unfocus-frame): Add obsolescence declaration and
+ empty docstring.
+
+ * international/mule.el (register-char-codings): Make alias for
+ `ignore'. Move docstring to obsolescence info and remove
+ redundancy.
+
+2004-06-02 Kim F. Storm <storm@cua.dk>
+
+ * frame.el (blink-cursor-start): Turn cursor off initially so blink
+ starts after blink-cursor-delay rather than 2*blink-cursor-delay.
+
+2004-05-31 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-arch.el (vc-arch-state): Don't assume the file exists.
+
+2004-05-31 Lars Hansen <larsh@math.ku.dk>
+
+ * desktop.el (desktop-save): Don't save minor modes without a
+ known mode initialization function.
+
+2004-05-30 Luc Teirlinck <teirllm@auburn.edu>
+
+ * replace.el (query-replace-interactive): Convert defvar -> defcustom.
+
+ * autorevert.el: Update `Commentary' section.
+
+2004-05-30 Juanma Barranquero <lektu@terra.es>
+
+ * dos-fns.el (convert-standard-filename):
+ * files.el (convert-standard-filename):
+ * w32-fns.el (convert-standard-filename):
+ Rework docstring (wording by Eli Zaretskii and Kai Grossjohann).
+
+2004-05-30 Kai Grossjohann <kai.grossjohann@gmx.net>
+
+ Sync with Tramp.
+
+ * net/tramp.el (tramp-let-maybe): Reverse args of `get'.
+ (tramp-let-maybe): Move to an earlier spot in the file.
+ Patch by Andreas Schwab.
+
+2004-05-30 Andreas Schwab <schwab@suse.de>
+
+ * dired.el (dired-get-filename): Don't use dired-re-dot.
+
+2004-05-30 Richard M. Stallman <rms@gnu.org>
+
+ * files.el (find-file): Doc fix.
+
+ * font-lock.el (lisp-font-lock-keywords-2): Add multiple-value-bind.
+
+2004-05-30 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el (gdb-current-frame, gud-watch)
+ (gdb-locals-mode, gdb-frame-handler): Display current frame in the
+ modeline of the locals buffer.
+ (gdb-goto-breakpoint): Handle gdbmi.
+ (gdb-get-frame-number): Change for gdbmi.
+
+2004-05-30 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (file-remote-p): Apply file name handler for operation
+ `file-remote-p'. It isn' a property any longer.
+ (file-relative-name): `fh' and `fd' get the required value via
+ `find-file-name-handler' already.
+
+ * ange-ftp.el (ange-ftp-file-remote-p): New defun.
+ (top): Remove setting of `file-remote-p' property for
+ `ange-ftp-hook-function'. Add `ange-ftp' property to `file-remote-p'.
+
+2004-05-29 Michael Albinus <michael.albinus@gmx.de>
+
+ Version 2.0.41 of Tramp released.
+
+ * tramp.el (tramp-wait-for-regexp, tramp-wait-for-output):
+ Throw away if process has died.
+ Reported by Luc Teirlinck <teirllm@dms.auburn.edu>.
+ (tramp-out-of-band-prompt-regexp): Rename to
+ `tramp-process-alive-regexp', because its usage is widen.
+ (tramp-actions-copy-out-of-band): Apply it.
+ (tramp-actions-before-shell, tramp-multi-actions):
+ Add `tramp-action-process-alive' action.
+ (tramp-action-process-alive): New defun.
+ (tramp-file-name-handler-alist, tramp-file-name-for-operation):
+ Add entry for `file-remote-p'.
+ (tramp-handle-file-remote-p): New defun.
+ (top): Remove setting of `file-remote-p'. Don't set
+ `inhibit-file-name-handlers' and `inhibit-file-name-operation'.
+
+ * tramp-smb.el (tramp-smb-file-name-handler-alist): Add entry for
+ `file-remote-p'.
+
+ * tramp-uu.el (tramp-uuencode-region): Padding characters aren't
+ counted for (last) line. [They should or they shouldn't? --Stef]
+ Reported by Aaron Ucko <ucko@ncbi.nlm.nih.gov>.
+
+2004-05-29 Kai Grossjohann <kai.grossjohann@gmx.net>
+
+ * tramp.el (tramp-initial-commands): Add "unset HISTFILE"; this is
+ not really necessary but seems to keep the shell history smaller
+ in some cases. It is no substitute for setting HISTFILE and
+ HISTSIZE from tramp-open-connection-setup-interactive-shell,
+ though. Suggested by Luc Teirlinck.
+ (tramp-open-connection-setup-interactive-shell): Export variables
+ HISTFILE and HISTSIZE, do not just set them. From Luc Teirlinck.
+ (tramp-set-process-query-on-exit-flag): New compat function.
+ (tramp-open-connection-multi, tramp-open-connection-su)
+ (tramp-open-connection-rsh, tramp-open-connection-telnet)
+ (tramp-do-copy-or-rename-file-out-of-band): Use it.
+ (tramp-let-maybe): New macro, let-binds a variable only if it
+ isn't obsolete.
+ (tramp-check-ls-commands, tramp-handle-expand-file-name)
+ (tramp-handle-file-truename): Use it.
+ (tramp-completion-file-name-regexp-unified): Avoid matching
+ filenames starting with "/:" -- those are reserved for
+ file-name-non-special.
+
+ * tramp-smb.el (tramp-smb-open-connection):
+ Use tramp-set-process-query-on-exit-flag compat function.
+
+2004-05-29 Richard M. Stallman <rms@gnu.org>
+
+ * net/browse-url.el (browse-url-interactive-arg): Doc fix.
+
+ * emacs-lisp/lisp-mode.el (prin1-char): Catch errors from `string'.
+ (eval-last-sexp-print-value): Print char equivalent regardless
+ of standard-output value.
+
+ * thumbs.el (thumbs-subst-char-in-string): Delete.
+ (thumbs-thumbname): Use subst-char-in-string.
+ (thumbs-resize-image): Use condition-case, not ignore-errors.
+ (thumbs-kill-buffer): Likewise.
+
+ * thumbs.el: Don't include cl. Don't bother with old Emacs versions.
+ (thumbs-mode): Make buffer read-only.
+ (thumbs-make-thumb): Unconditionally accept an existing file.
+ (thumbs-insert-thumb): Add thumb-image-file property to the image.
+ (thumbs-do-thumbs-insertion): Be smarter about where to put newlines.
+ (thumbs-show-thumbs-list): Error if images not supported.
+ (thumbs-save-current-image): Improve prompt string.
+ (thumbs-mode-map): Define u, R, x.
+ (thumbs-unmark): New command.
+ (thumbs-emboss-image): Minor cleanup.
+ (thumbs-forward-char, thumbs-backward-char): Skip chars with no image.
+ (thumbs-rename-images): New command.
+ (thumbs-show-image-num): Rewrite. Don't rename the buffer.
+
+ * thumbs.el (thumbs-current-image): New function.
+ (thumbs-file-list, thumbs-file-alist): New functions.
+ (thumbs-find-image): Delete arg L.
+ Don't set up thumbs-fileL as buffer-local global var.
+ (thumbs-find-image-at-point): Use thumbs-current-image.
+ (thumbs-set-image-at-point-to-root-window): Likewise.
+ (thumbs-delete-images): Use thumbs-current-image, thumbs-file-alist.
+ Record and warn about errors. Update thumbs-markedL for deletions.
+ (thumbs-next-image, thumbs-previous-image): Use thumbs-file-alist.
+ (thumbs-redraw-buffer): Use thumbs-file-list.
+ (thumbs-mark): Use thumbs-current-image.
+ (thumbs-show-name): Use thumbs-current-image.
+
+ * imenu.el (imenu--menubar-select): Set imenu-menubar-modified-tick
+ and imenu--last-menubar-index-alist.
+
+ * subr.el (with-selected-window): Undo previous change.
+
+2004-05-29 John Paul Wallington <jpw@gnu.org>
+
+ * thumbs.el (thumbs-show-name): Do nothing if no image at point.
+ (thumbs-mouse-find-image): New command.
+ (thumbs-mode-map): Bind it to mouse-2.
+ (thumbs-mode): Make mode-class special.
+ (thumbs-view-image-mode): Likewise.
+
+2004-05-29 Pavel Kobiakov <pk_at_work@yahoo.com>
+
+ * flymake.el: New file.
+
+2004-05-28 Luc Teirlinck <teirllm@auburn.edu>
+
+ * files.el (find-file-noselect-1): Do not bind
+ `inhibit-read-only' to t during execution of
+ `find-file-not-found-functions'.
+
+2004-05-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * vc-mcvs.el (vc-mcvs-print-log, vc-mcvs-diff):
+ * vc-arch.el (vc-arch-diff): Add optional `buffer' arg.
+
+2004-05-28 Juri Linkov <juri@jurta.org>
+
+ * simple.el (eval-expression-print-format): New fun.
+
+ * simple.el (eval-expression):
+ * emacs-lisp/lisp-mode.el (eval-last-sexp-print-value):
+ * emacs-lisp/edebug.el (edebug-compute-previous-result)
+ (edebug-eval-expression): Print additionally the value returned by
+ `eval-expression-print-format'.
+
+ * emacs-lisp/lisp.el (insert-pair-alist): New var.
+ (insert-pair): Make arguments optional. Find character pair
+ from `insert-pair-alist' according to the last input event.
+ (insert-parentheses): Make arguments optional.
+ (raise-sexp, delete-pair): New funs.
+
+ * emacs-lisp/lisp-mode.el (indent-pp-sexp): New fun.
+ (emacs-lisp-mode-map, lisp-interaction-mode-map):
+ Bind C-M-q to `indent-pp-sexp'.
+
+ * emacs-lisp/pp.el (pp-buffer): New fun created from the code in
+ `pp-to-string' modified to be able to format text with newlines.
+ (pp-to-string): Move the buffer-formatting part of the code to
+ `pp-buffer'. Call `pp-buffer'.
+
+ * info.el (Info-desktop-buffer-misc-data): Don't save information
+ about virtual files.
+ (Info-restore-desktop-buffer): Restore Info buffers in prepared
+ buffers with names obtained from the desktop file instead of the
+ default *info* buffer.
+
+2004-05-28 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (with-selected-window): Only save/restore the selected window.
+
+ * progmodes/compile.el (compilation-error-regexp-alist):
+ Use expand-file-name and data-directory.
+
+ * progmodes/grep.el (grep-tree): Rework previous fix.
+
+ * mouse.el (mouse-set-region-1): Use temporary transient-mark-mode
+ after the user marked text with the mouse.
+
+ * startup.el (command-line): Keep the first regexp of
+ auto-save-file-name-transforms intact.
+
+2004-05-28 Juanma Barranquero <lektu@terra.es>
+
+ * cus-edit.el (customize-face, customize-face-other-window)
+ (custom-face-edit-delete): Make arguments match their use in
+ docstring.
+ (custom-unloaded-symbol-p, custom-unloaded-widget-p): Fix typo in
+ docstring.
+
+ * cvs-status.el (cvs-tree-merge, cvs-tags->tree): Use `butlast',
+ not `cvs-butlast'.
+
+ * pcvs-util.el (cvs-butlast, cvs-nbutlast): Remove (`butlast' and
+ `nbutlast' are in subr.el).
+
+ * w32-fns.el (w32-using-nt, w32-shell-dos-semantics)
+ (set-w32-system-coding-system): Doc fixes.
+
+ * textmodes/artist.el (artist-last, artist-remove-nulls): Simplify.
+ (artist-draw-ellipse-general, artist-draw-ellipse-with-0-height):
+ Make arguments match their use in docstring.
+ (artist-draw-region-trim-line-endings)
+ (artist-mouse-choose-operation): Fix typo in docstring.
+ (artist-key-set-point-common): Doc fix.
+
+2004-05-28 Simon Josefsson <jas@extundo.com>
+
+ * mail/smtpmail.el (smtpmail-open-stream):
+ Bind starttls-extra-arguments too, if starttls.el uses GNUTLS.
+
+2004-05-26 Simon Josefsson <jas@extundo.com>
+
+ * starttls.el: Merge with my GNUTLS based starttls.el.
+ (starttls-gnutls-program, starttls-use-gnutls)
+ (starttls-extra-arguments, starttls-process-connection-type)
+ (starttls-connect, starttls-failure, starttls-success): New variables.
+ (starttls-program, starttls-extra-args): Doc fix.
+ (starttls-negotiate-gnutls, starttls-open-stream-gnutls): New funs.
+ (starttls-negotiate, starttls-open-stream): Check `starttls-use-gnutls'
+ and pass on to corresponding *-gnutls function if it is set.
+
+2004-05-27 Luc Teirlinck <teirllm@auburn.edu>
+
+ * autorevert.el (auto-revert-handler): Disable auto-reverting of
+ remote files.
+
+2004-05-27 Michael Albinus <michael.albinus@gmx.de>
+
+ * files.el (file-name-non-special): There are more operations
+ which need handling: `find-backup-file-name',
+ `insert-file-contents', `verify-visited-file-modtime',
+ `write-region'. Rename t value of method to `add'. Add new
+ methods `quote' and `unquote-then-quote' to file-arg-indices.
+
+2004-05-25 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-toc): Call Info-mode on intermediate buffer.
+ (Info-index-nodes): Enclose code in condition-case to catch errors.
+ (Info-index-node): Don't search all index nodes if request is only
+ for the current node and file is not in the cache of index nodes.
+ (Info-mode-map): Bind Info-copy-current-node-name to `w'
+ for consistency with dired-copy-filename-as-kill.
+ Bind `S' to Info-search-case-sensitively.
+ (Info-copy-current-node-name): New arg. With zero prefix arg put
+ the name inside a function call to `info'. Display copied text in
+ the echo area.
+
+2004-05-25 Sam Steingold <sds@gnu.org>
+
+ * emacs-lisp/lisp-mode.el (lisp-find-tag-default): New function:
+ strip the package prefix from the symbol name, if any.
+ Make it the `find-tag-default-function' for `lisp-mode'.
+
+2004-05-25 John Paul Wallington <jpw@gnu.org>
+
+ * gs.el (gs-load-image): Use `set-process-query-on-exit-flag'
+ instead of obsolete `process-kill-without-query'.
+
+ * textmodes/texinfmt.el (texinfo-indexvar-alist):
+ Declare as variable, not constant.
+
+2004-05-25 Luc Teirlinck <teirllm@auburn.edu>
+
+ * files.el (find-file-noselect-1): Fix bug introduced by
+ Revision 1.694. As a side effect, `inhibit-read-only'
+ is again, by default, t during execution of
+ `find-file-not-found-functions'.
+ (insert-directory): Check that lines were really inserted by
+ the --dired switch, before erasing them.
+
+2004-05-24 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el (gdb-breakpoints-mode, gdb-frames-mode)
+ (gdb-locals-mode): Check gud-minor-mode in gud-comint-buffer.
+ (gdb-var-update, gdb-var-update-handler, gdb-var-delete)
+ (gdb-edit-value, gdb-speedbar-expand-node): Handle new value for
+ gud-minor-mode (gdbmi).
+
+2004-05-24 Yoichi NAKAYAMA <yoichi@geiin.org> (tiny change)
+
+ * net/browse-url.el (browse-url-interactive-arg): Enable user to
+ explicitly select the text to be taken as URL.
+
+2004-05-23 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-index-nodes): New var and fun.
+ (Info-goto-index, Info-index, info-apropos)
+ (Info-find-emacs-command-nodes): Rewrite to use Info-index-nodes.
+ (Info-index): Fix docstring. Store and restore Info-history-list.
+ (Info-complete-nodes): New var.
+ (Info-complete-menu-item): Use it.
+ (Info-index-node): New fun.
+ (Info-final-node, Info-forward-node, Info-backward-node)
+ (Info-build-toc, Info-try-follow-nearest-node, Info-fontify-node):
+ Use Info-index-node.
+ (Info-extract-menu-item, Info-extract-menu-counting): Set second
+ arg of `Info-extract-menu-node-name' to non-nil for index nodes.
+ (Info-find-node-2): If a node with period in its name not found,
+ try to find a node without the name part after period.
+ (Info-select-node): Call Info-fontify-node only if
+ Info-fontify-maximum-menu-size is not nil.
+ (info-apropos): Set Info-fontify-maximum-menu-size to nil.
+ (Info-find-emacs-command-nodes, Info-goto-emacs-command-node):
+ Preserve Info-history-list.
+ (Info-toc): Set Info-current-file.
+ (Info-build-toc): Move point to the beginning of the buffer.
+ Add main-file variable.
+ (Info-dir-remove-duplicates, Info-history, Info-toc, info-apropos):
+ Use backslashed representation of the control character ^_.
+
+ * textmodes/texinfmt.el (texinfo-print-index): Print index line
+ numbers in the new Texinfo 4.7 format.
+
+ * add-log.el (change-log-font-lock-keywords): Remove `:' from
+ regexps for function and variable names.
+
+ * descr-text.el (describe-property-list): Add [show] button for
+ `syntax-table' property with action to pp to a separate buffer.
+ (describe-char): Replace search-forward by re-search-forward with
+ whitespace regexp after "character:" to not fail in too narrow windows.
+
+ * simple.el (next-error-find-buffer): Add a rule to return
+ next-error capable buffer if one window on the selected frame
+ displays such buffer.
+
+2004-05-23 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el (gdb-server-prefix): New variable.
+ (gud-watch, gdb-send-item, gdb-breakpoints-mode, gdb-frames-mode)
+ (gdb-locals-mode, gdb-send-item, gdb-toggle-breakpoint)
+ (gdb-delete-breakpoint, gdb-frames-select, gdb-threads-buffer)
+ (gdb-registers-buffer, gdb-reset, gdb-assembler-buffer):
+ Handle new value for gud-minor-mode (gdbmi).
+ (gdb-buffer-type, gdb-input-queue, gdb-prompting)
+ (gdb-output-sink, gdb-current-item, gdb-pending-triggers):
+ Change from local to global gdb variable set.
+ (gdb-ann3): Initialise above gdb variable set.
+ (gdb-var-update, gdb-var-update-handler, gdb-enqueue-input)
+ (gdb-dequeue-input, gdb-source, gdb-pre-prompt, gdb-prompt)
+ (gdb-subprompt, gdb-starting, gdb-stopping, gdb-frame-begin)
+ (gdb-stopped, gdb-post-prompt, gdb-concat-output)
+ (def-gdb-auto-update-trigger, def-gdb-auto-update-handler)
+ (gdb-info-locals-handler, gdb-invalidate-assembler)
+ (gdb-get-current-frame, gdb-frame-handler): Handle gdb variable
+ set as global variables.
+ (gdb-get-create-buffer): Don't make gud-comint buffer-local.
+ Handle gdbmi.
+ (gdb-info-breakpoints-custom): Fix regexp.
+ (def-gdb-var): Delete.
+
+ * progmodes/gud.el (gud-menu-map, gud-speedbar-menu-items)
+ (gud-speedbar-buttons, gud-sentinel, gud-display-line)
+ (gud-basic-call): Handle new value for gud-minor-mode (gdbmi) for
+ a new mode. The file (gdb-mi.el) for this mode will be included
+ with the GDB distribution (6.2 onwards) and will use GDB/MI as its
+ primary interface.
+
+2004-05-23 Jesper Harder <harder@ifa.au.dk>
+
+ * progmodes/grep.el (grep-tree): Ensure that DIR argument is
+ interpreted as a directory.
+
+2004-05-22 Richard M. Stallman <rms@gnu.org>
+
+ * textmodes/paragraphs.el (sentence-end): Match unicode curly quotes
+ as a close quote.
+
+ * textmodes/bibtex.el: Use assoc-string, not assoc-ignore-case.
+
+ * progmodes/idlw-shell.el (idlwave-shell-get-object-class):
+ Use assoc-string, not assoc-ignore-case.
+
+ * progmodes/ada-mode.el: Use assoc-string, not assoc-ignore-case.
+
+ * emacs-lisp/lisp.el (mark-defun, narrow-to-defun):
+ If moving back then fwd gets a defun that ends before point,
+ try again moving fwd then back.
+
+ * files.el (file-name-non-special): Allow t in file-arg-indices
+ to mean requote the return value. Use `identity' as an element
+ rather than as the whole value.
+
+ * gs.el (gs-options): Add -dSAFER. Mark it risky.
+
+2004-05-22 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-add-fundoc-usage): Use %S only for output of
+ `help-make-usage'.
+ (help-highlight-arguments): Skip function name before searching
+ for arguments.
+
+2004-05-21 Juanma Barranquero <lektu@terra.es>
+
+ * allout.el (allout-chart-subtree, allout-rebullet-topic-grunt):
+ Don't mention in the docstring these arguments meant for
+ internal (recursive) use only.
+ (allout-char-spec): Comment out (it's not implemented).
+ (allout-old-expose-topic, allout-exposure): Fix docstring and add
+ obsolescence declaration.
+ (allout-flatten-exposed-to-buffer)
+ (allout-indented-exposed-to-buffer): Fix typos in docstring.
+ (my-mark-marker): Doc fix.
+ (produce-allout-mode-map, allout-sibling-index)
+ (allout-isearch-expose, allout-distinctive-bullet)
+ (allout-open-topic, allout-reindent-body)
+ (allout-rebullet-heading, allout-process-exposed)
+ (allout-insert-listified, allout-latex-verb-quote)
+ (allout-insert-latex-header, allout-insert-latex-trailer):
+ Make arguments match their use in docstring.
+ (allout-primary-bullet, allout-old-style-prefixes)
+ (allout-inhibit-protection, allout-init, allout-mode)
+ (allout-before-change-protect, allout-flag-region):
+ Use "Emacs" instead of "emacs" in docstrings.
+
+2004-05-21 Masayuki Ataka <ataka@milk.freemail.ne.jp> (tiny change)
+
+ * international/characters.el: Modify syntax of more characters.
+
+2004-05-21 Masatake YAMATO <jet@gyve.org>
+
+ * progmodes/etags.el (tags-apropos, list-tags): Require apropos.
+ (etags-tags-completion-table): Show parsing progress.
+
+2004-05-20 Luc Teirlinck <teirllm@auburn.edu>
+
+ * locate.el (locate-prompt-for-command): Shorten first line of
+ docstring.
+ (locate-mode): Expand docstring and include keymap summary.
+
+ * files.el (find-file-noselect-1): Limit the scope of the
+ `inhibit-read-only' binding. Make sure that `inhibit-read-only'
+ is, by default, nil during the execution of
+ `find-file-not-found-functions' and `find-file-hook'.
+
+2004-05-20 Michael Mauger <mmaug@yahoo.com>
+
+ * facemenu.el (facemenu-color-name-equal): New function.
+ (list-colors-display): Use it to compare colors instead of
+ facemenu-color-equal.
+
+2004-05-20 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * compare-w.el (compare-windows-face): Use min-colors instead of
+ checking for tty or pc types.
+
+2004-05-19 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * simple.el (do-auto-fill): Remove unused vars `bol' and `opoint'.
+ (completion-setup-function): Use with-current-buffer.
+ Properly save excursion. Simplify.
+ Don't assume there is necessarily a `mouse-face' property somewhere.
+
+ * progmodes/gud.el (gud-reset): Use unless & with-current-buffer.
+
+ * progmodes/gdb-ui.el (gdb-reset): Use unless. Fix regexp.
+
+ * emacs-lisp/bytecomp.el (byte-compile-log): Use backquotes.
+ (byte-compile-log-1): Don't call (byte-goto-log-buffer).
+ Use with-current-buffer.
+ (byte-goto-log-buffer): Delete.
+ (byte-compile-log-file): Call compilation-forget-errors.
+
+2004-05-19 Takaaki Ota <Takaaki.Ota@am.sony.com> (tiny change)
+
+ * net/ldap.el (ldap-search-internal): Avoid mixing standard error
+ output messages into the search result.
+
+2004-05-19 Masatake YAMATO <jet@gyve.org>
+
+ * wid-edit.el (widget-radio-button-notify): Revert my last
+ change. Reported by Katsumi Yamaoka <yamaoka@jpl.org>.
+
+2004-05-19 Kenichi Handa <handa@m17n.org>
+
+ * international/characters.el: Fix syntax (open/close) of CJK chars.
+
+2004-05-18 Karl Chen <quarl@hkn.eecs.berkeley.edu> (tiny change)
+
+ * help-mode.el (help-go-back): Don't depend on position of back button.
+
+2004-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * files.el (auto-save-file-name-transforms): Make sure ange-ftp temp
+ files files don't contain an accidental additional /.
+
+ * textmodes/tex-mode.el (tex-compilation-parse-errors): Save excursion
+ in source buffer.
+
+2004-05-18 Masatake YAMATO <jet@gyve.org>
+
+ * wid-edit.el (widget-radio-button-notify): Don't pass `widget'
+ to widget-apply. :action method assumes 2 arguments, not 3.
+
+2004-05-17 Glenn Morris <gmorris@ast.cam.ac.uk>
+
+ * progmodes/f90.el (f90-end-block-re, f90-start-block-re):
+ New constants.
+ (hs-special-modes-alist): Add an f90-mode entry.
+
+2004-05-17 Sam Steingold <sds@gnu.org>
+
+ * emacs-lisp/cl-indent.el (common-lisp-indent-function-1):
+ Indent "without-" forms just like "with-" and "do-". Use regexp-opt.
+
+2004-05-16 Kim F. Storm <storm@cua.dk>
+
+ * emacs-lisp/timer.el (timer-event-handler): Fix last change.
+
+2004-05-15 John Wiegley <johnw@newartisans.com>
+
+ * eshell/esh-io.el (eshell-get-target): Whitespace changes.
+ (eshell-output-object-to-target): Improve output speed 20% by not
+ calling `eshell-stringify' if something is already known to be a string.
+
+2004-05-15 Alex Ott <ott@jet.msk.su>
+
+ * textmodes/ispell.el (ispell-local-dictionary-alist):
+ Add windows-1251 to the choice of coding systems.
+ (ispell-dictionary-alist-6): Add support for "russianw.aff",
+ encoded in cp1251.
+
+2004-05-15 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * progmodes/compile.el (compilation-warning-face)
+ (compilation-info-face): Use min-colors.
+
+2004-05-15 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * toolbar/close.pbm, toolbar/close.xpm, toolbar/copy.pbm
+ * toolbar/copy.xpm, toolbar/cut.pbm, toolbar/cut.xpm
+ * toolbar/help.pbm, toolbar/help.xpm, toolbar/home.pbm
+ * toolbar/home.xpm, toolbar/index.pbm, toolbar/index.xpm
+ * toolbar/jump_to.pbm, toolbar/jump_to.xpm, toolbar/left_arrow.pbm
+ * toolbar/left_arrow.xpm, toolbar/new.pbm, toolbar/new.xpm
+ * toolbar/open.pbm, toolbar/open.xpm, toolbar/paste.pbm
+ * toolbar/paste.xpm, toolbar/preferences.pbm, toolbar/preferences.xpm
+ * toolbar/print.pbm, toolbar/print.xpm, toolbar/right_arrow.pbm
+ * toolbar/right_arrow.xpm, toolbar/save.pbm, toolbar/save.xpm
+ * toolbar/saveas.pbm, toolbar/saveas.xpm, toolbar/search.pbm
+ * toolbar/search.xpm, toolbar/spell.pbm, toolbar/spell.xpm
+ * toolbar/undo.pbm, toolbar/undo.xpm, toolbar/up_arrow.pbm
+ * toolbar/up_arrow.xpm: New icons from GTK+ version 2.
+
+2004-05-15 Kim F. Storm <storm@cua.dk>
+
+ * emacs-lisp/timer.el (timer-activate): Add optional arg triggered-p.
+ Use it to set triggered-p element of timer.
+ (timer-event-handler): Set triggered-p element non-nil while running
+ the timer function.
+
+2004-05-14 David Ponce <david@dponce.com>
+
+ * tree-widget.el: New file.
+
+2004-05-13 Marcelo Toledo <marcelo@marcelotoledo.org>
+
+ * language/european.el ("Brazilian Portuguese"): Add support for
+ Brazilian Portuguese.
+
+2004-05-13 John Wiegley <johnw@newartisans.com>
+
+ * iswitchb.el (iswitchb-use-virtual-buffers): Only turn on
+ `recentf-mode' if this variable has been customized to t.
+
+ * eshell/esh-test.el (eshell-test): Call the function
+ `emacs-version' rather than trying to build a custom version string.
+
+2004-05-13 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * net/telnet.el (telnet-mode): Use define-derived-mode.
+ Don't modify the global value of comint-prompt-regexp.
+
+2004-05-13 John Paul Wallington <jpw@gnu.org>
+
+ * version.el (emacs-version): Check for `gtk' feature before
+ `x-toolkit' feature.
+
+2004-05-13 Juanma Barranquero <lektu@terra.es>
+
+ * files.el (file-truename): Don't mention COUNTER and PREV-DIRS
+ arguments in the docstring, they're used only in recursive calls.
+
+ * help-fns.el (help-arg-highlighting-function)
+ (help-argument-name): Delete.
+ (help-default-arg-highlight): New function.
+ (help-do-arg-highlighting): Use it.
+
+2004-05-13 Glenn Morris <gmorris@ast.cam.ac.uk>
+
+ * calendar/appt.el (appt-disp-window):
+ Use `calendar-set-mode-line' for a centered mode-line.
+
+2004-05-13 Takaaki Ota <Takaaki.Ota@am.sony.com> (tiny change)
+
+ * calendar/appt.el (appt-disp-window): Do not split window
+ excessively when `split-height-threshold' is low.
+
+2004-05-12 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gud.el (gud-mode): Add gud-kill-buffer-hook to
+ kill-buffer-hook here and make it local.
+ (gud-kill-buffer-hook): Use kill-process for a sure kill.
+
+2004-05-12 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compilation-set-window-height):
+ Use save-excursion to protect against misplaced marker.
+
+2004-05-12 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * custom.el (defface): Document that type can have value gtk.
+
+ * faces.el (face-spec-set-match-display): Handle type gtk in display.
+
+2004-05-12 Kenichi Handa <handa@m17n.org>
+
+ * descr-text.el: Require quail at comile time.
+ (describe-char): If an input method is on and it supports the
+ character, show how to input it.
+
+ * international/quail.el (quail-install-decode-map): Accept a
+ char-table whose subtype is `quail-decode-map'.
+ (quail-store-decode-map-key, quail-gen-decode-map1)
+ (quail-gen-decode-map, quail-find-key1, quail-find-key)
+ (quail-show-key): New functions.
+
+2004-05-12 Juanma Barranquero <lektu@terra.es>
+
+ * generic.el (define-generic-mode): Remove redundant arglist info.
+
+ * help-fns.el (help-split-fundoc, help-add-fundoc-usage):
+ Make arguments match their use in docstring.
+ (help-arg-highlighting-function): New variable.
+ (help-argument-name): Mention it in the docstring.
+ (help-do-arg-highlight): Use it. Expand regexp to accept also
+ ARG-xxx and xxx-ARG references.
+
+2004-05-11 Yoichi NAKAYAMA <yoichi@geiin.org> (tiny change)
+
+ * mail/rfc2368.el (rfc2368-parse-mailto-url): Make the results of
+ parsing "mailto:addr1%2C%20addr2", "mailto:?to=addr1%2C%20addr2",
+ and "mailto:addr1?to=addr2" equal.
+
+2004-05-11 Alexander Pohoyda <alexander.pohoyda@gmx.net> (tiny change)
+
+ * man.el (Man-getpage-in-background): Use shell-file-name
+ and shell-command-switch variables instead of hard-coded values.
+
+2004-05-11 Eli Zaretskii <eliz@gnu.org>
+
+ * iimage.el: New file.
+
+2004-05-11 Juanma Barranquero <lektu@terra.es>
+
+ * custom.el (custom-initialize-default, defcustom):
+ Fix typo in docstring.
+
+ * files.el (set-visited-file-name, file-expand-wildcards):
+ Fix docstring.
+
+2004-05-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/lisp-mode.el (prin1-char): Use eventp.
+
+ * subr.el (eventp): Be more discriminating with integers.
+
+2004-05-10 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compile): Add universal prefix arg.
+ (compilation-error-regexp-alist-alist): Add edg patterns.
+
+2004-05-10 Sam Steingold <sds@gnu.org>
+
+ * textmodes/ispell.el (ispell-message):
+ Use `message-cite-prefix-regexp' instead of `message-yank-prefix'.
+
+2004-05-10 Dave Love <fx@gnu.org>
+
+ * progmodes/python.el (help-buffer): Autoload when compiling.
+ (python-after-info-look): Don't assume Info-goto-node returns non-nil.
+ (run-python): Prepend to any existing PYTHONPATH.
+
+2004-05-10 Nick Roberts <nick@nick.uklinux.net>
+
+ * progmodes/gdb-ui.el (gdb-annotation-rules): Add nquery annotation
+ for pending breakpoints.
+
+2004-05-10 Richard M. Stallman <rms@gnu.org>
+
+ * mail/unrmail.el (unrmail): Mostly rewritten. Parses the file
+ directly without calling any functions in Rmail.
+ (unrmail-unprune): Function deleted.
+
+2004-05-10 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (inferior-python-mode-map): Remove erroneous
+ C-c C-z binding.
+
+2004-05-10 Kenichi Handa <handa@m17n.org>
+
+ * descr-text.el (describe-char): Fix previous change. Don't make
+ a unibyte character to multibyte in the *Help* buffer.
+
+2004-05-10 Miles Bader <miles@gnu.org>
+
+ * lisp/progmodes/gud.el (gud-common-init): Only consider an existing
+ buffer an error if the debugger process is actually running.
+
+2004-05-10 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-argument-name): Default to italic.
+ (help-highlight-arguments): Return always (usage . doc), even when
+ usage is nil.
+
+ * ibuf-macs.el (define-ibuffer-column, define-ibuffer-sorter)
+ (define-ibuffer-filter): Add usage info.
+ (define-ibuffer-op): Add usage info (but CL-style defaults for
+ keyword args are not shown).
+
+ * subr.el (remove-overlays, read-passwd): Fix docstring.
+ (start-process-shell-command): Fix docstring. Put usage info in a
+ format usable by `describe-function'.
+ (open-network-stream, open-network-stream-nowait)
+ (open-network-stream-server): Fix docstring.
+
+2004-05-09 Jason Rumney <jasonr@gnu.org>
+
+ * international/code-pages (cp932, cp936, cp949, c950): Remove.
+ Only define cp125* if windows-125* is already defined.
+
+ * language/korean.el (cp949): Add alias.
+
+ * language/chinese.el (cp936, cp950): Add aliases.
+
+ * language/japanese.el (cp932): Add alias.
+
+ * term/w32-win.el: Require code-pages.
+
+ * international/mule-cmds.el (set-locale-environment):
+ On MS-Windows use ansi code-page for default coding-systems.
+ Set up paper sizes for Windows 3 letter languages.
+
+ * international/code-pages.el (cp932, cp936, cp949, cp950):
+ Add aliases. Also add cp125* if not already defined.
+
+2004-05-09 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-highlight-arguments): Don't try to highlight
+ missing or autoloaded arglists. Accept structured arguments, like
+ the first ones of `do' and `flet'.
+
+ * pcvs.el (cvs-mode-run, cvs-is-within-p): Fix typo in docstring.
+ (cvs-get-marked): Remove redundant arglist info.
+
+ * net/quickurl.el (quickurl, quickurl-browse-url, quickurl-read):
+ Don't use CL-style default args.
+
+2004-05-08 Andreas Schwab <schwab@suse.de>
+
+ * emacs-lisp/checkdoc.el (checkdoc-minor-mode): Doc fix.
+
+ * international/subst-ksc.el: Fix references to utf-translate-cjk
+ into utf-translate-cjk-mode.
+ * international/subst-big5.el: Likewise.
+ * international/subst-gb2312.el: Likewise.
+ * international/subst-jis.el: Likewise.
+ * international/utf-16.el: Likewise.
+ * international/utf-8.el: Likewise.
+
+2004-05-08 John Wiegley <johnw@newartisans.com>
+
+ * iswitchb.el (iswitchb-use-virtual-buffers): Add support for
+ "virtual buffers" (off by default), which makes it possible to
+ switch to the "virtual" buffers of recently visited files. When a
+ buffer name search fails, and this option is on, iswitchb will
+ look at the list of recently visited files, and permit matching
+ against those names. When the user hits RET on a match, it will
+ revisit that file.
+ (iswitchb-read-buffer): Add two optional arguments, which makes
+ isearchb.el possible.
+ (iswitchb-completions, iswitchb-set-matches, iswitchb-prev-match)
+ (iswitchb-next-match): Add support for virtual buffers.
+
+ * isearchb.el: This module extends iswitchb to provide "as you
+ type" buffer selection.
+
+ * textmodes/flyspell.el (flyspell-highlight-incorrect-region):
+ Ignore the read-only property when flyspell highlighting is on.
+ Not ignoring it leads to a series of confusing errors.
+ (flyspell-highlight-duplicate-region): Ignore read-only, as above,
+ but also make sure to call flyspell-incorrect-hook.
+ (flyspell-maybe-correct-transposition): Perform transposition test
+ by bit twiddling a string, rather than using a temp buffer.
+ (flyspell-maybe-correct-doubling): Use a string rather than a temp
+ buffer. This is also the original version of the code, which
+ could not be checked in before due to a previous lack of
+ assignment papers. This version has seen heavy usage on my system
+ for several years now.
+
+ * calendar/cal-bahai.el: New file, which adds support for the
+ Baha'i calendar to Emacs. This calendar is based on a solar year
+ of 19 months of 19 days, with 4 intercalary days. Each year
+ begins on March 21, with the calendar starting in 1844.
+
+ * calendar/cal-menu.el, calendar/calendar.el,
+ calendar/diary-lib.el, calendar/holidays.el: Added support for
+ using cal-bahai.el.
+
+ * eshell/em-glob.el (eshell-glob-initialize): Move initialization
+ of `eshell-glob-chars-regexp' into `eshell-glob-regexp', so that
+ function can be used outside of eshell buffers.
+ (eshell-glob-regexp): Initialize `eshell-glob-chars-regexp' here.
+
+2004-05-08 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-do-arg-highlight): Temporarily set ?\- to be a
+ word constituent so FOO-ARG is not recognized as an arg.
+ (help-highlight-arguments): Don't skip lists in mandatory arguments.
+
+ * simple.el (next-error): Fix typo in docstring.
+ (open-line): Make argument names match their use in docstring.
+ (split-line): Fix docstring.
+
+ * emacs-lisp/cl-macs.el (do, do*): Put usage info in a format
+ usable by `describe-function'.
+ (gensym, gentemp, typep, ignore-errors): Make argument names match
+ their use in docstring.
+
+ * progmodes/python.el (python-describe-symbol): Pass INTERACTIVE-P
+ argument to `help-setup-xref'.
+
+2004-05-07 Kai Grossjohann <kai@emptydomain.de>
+
+ Version 2.0.40 of Tramp released.
+
+ * net/tramp.el (tramp-completion-mode, tramp-md5-function):
+ Use symbol-function to invoke functions only known on some Emacs
+ flavors. This avoids byte-compiler warnings. Reported by Kevin
+ Scaldeferri <kevin@scaldeferri.com>.
+ (tramp-do-copy-or-rename-file-via-buffer): Rename from
+ tramp-do-copy-or-rename-via-buffer (without `file'), to make it
+ consistent with the other tramp-do-* functions.
+ (tramp-do-copy-or-rename-file): Calls adjusted.
+ (tramp-process-initial-commands): Avoid liveness check on shell --
+ we know that it must be alive since we're opening a connection at
+ this moment.
+ (tramp-last-cmd): New internal variable.
+ (tramp-process-echoes): New tunable.
+ (tramp-send-command): Set tramp-last-cmd.
+ (tramp-wait-for-output): Delete echo, if applicable.
+ (tramp-read-passwd): Construct the key for the password cache in a
+ way that works for multi methods, too.
+ (tramp-bug): Add backup-directory-alist and
+ bkup-backup-directory-info to bug reports, with Tramp counterparts.
+
+2004-05-07 Michael Albinus <michael.albinus@gmx.de>
+
+ * net/tramp*.el: Suppress byte-compiler warnings where possible.
+
+ * net/tramp.el (tramp-out-of-band-prompt-regexp)
+ (tramp-actions-copy-out-of-band): New defcustoms.
+ (tramp-do-copy-or-rename-file-out-of-band): Asynchronous process
+ used instead of a synchronous one. Allows password entering.
+ (tramp-action-out-of-band): New defun.
+ (tramp-open-connection-rsh, tramp-method-out-of-band-p):
+ Remove restriction with password from doc string.
+ (tramp-bug): Add variables `tramp-terminal-prompt-regexp',
+ `tramp-out-of-band-prompt-regexp',
+ `tramp-actions-copy-out-of-band', `password-cache' and
+ `password-cache-expiry'.
+ (toplevel): Remove todo item wrt ssh-agent. Obsolete due to
+ password caching.
+ (tramp-touch): FILE can be a local file, too.
+ (TODO): Remove items done.
+ (tramp-handle-insert-directory): Properly quote file name also if
+ not full-directory-p. Handle wildcard case. Reported by Andreas
+ Schwab <schwab@suse.de>.
+ (tramp-do-copy-or-rename-file-via-buffer): Set permissions of the
+ new file.
+ (tramp-handle-file-local-copy, tramp-handle-write-region):
+ The permissions of the temporary file are set if filename exists.
+ Reported by Ted Stern <stern@cray.com>.
+ (tramp-backup-directory-alist)
+ (tramp-bkup-backup-directory-info): New defcustoms.
+ (tramp-file-name-handler-alist): Add entry for `find-backup-file-name'.
+ (tramp-handle-find-backup-file-name): New function.
+ Implements Tramp's find-backup-file-name.
+
+ * net/tramp-smb.el (tramp-smb-file-name-handler-alist): Add entry
+ for `find-backup-file-name'.
+
+ * net/tramp-vc.el (tramp-vc-workfile-unchanged-p): Correct typo
+ ("file" -> "filename"). Reported by Kim F. Storm <storm@cua.dk>.
+
+2004-05-07 Lars Hansen <larsh@math.ku.dk>
+
+ * desktop.el (desktop-buffer-mode-handlers): Fix docstring.
+
+2004-05-07 Juanma Barranquero <lektu@terra.es>
+
+ * subr.el (lambda): Add arglist description to docstring.
+ (declare): Fix typo in docstring.
+ (open-network-stream): Fix docstring.
+ (process-kill-without-query): Fix docstring and add obsolescence info.
+ (last, butlast, nbutlast): Make arguments match their use in docstring.
+ (insert-buffer-substring-no-properties): Likewise.
+ (insert-buffer-substring-as-yank): Likewise.
+ (split-string): Fix docstring.
+
+ * emacs-lisp/byte-run.el (make-obsolete, make-obsolete-variable):
+ Make argument names match their use in docstring.
+
+ * emacs-lisp/re-builder.el (reb-auto-update): Fix typo in docstring.
+
+2004-05-06 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el: Improve/extend documentation strings.
+ Fit first sentence on one line for apropos-command.
+
+2004-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ Changes largely merged in from Dave Love's code.
+ * progmodes/python.el: Doc fixes.
+ (python-mode-map): Add python-complete-symbol.
+ (python-comment-line-p, python-beginning-of-string): Use syntax-ppss.
+ (python-comment-indent, python-complete-symbol)
+ (python-symbol-completions, python-partial-symbol)
+ (python-try-complete): New.
+ (python-indent-line): Remove optional arg. Use python-block-end-p.
+ (python-check): Bind compilation-error-regexp-alist.
+ (inferior-python-mode): Use rx. Move keybindings to top level.
+ Set comint-input-filter.
+ (python-preoutput-filter): Use rx.
+ (python-input-filter): Re-introduce.
+ (python-proc): Start new process if necessary.
+ Check python-buffer non-nil.
+ (view-return-to-alist): Defvar.
+ (python-send-receive): New.
+ (python-eldoc-function): Use it.
+ (python-mode-running): Don't defvar.
+ (python-mode): Set comment-indent-function.
+ Maybe update hippie-expand-try-functions-list.
+ (python-indentation-levels): Initialize differently.
+ (python-block-end-p): New.
+ (python-indent-line): Use it.
+ (python-compilation-regexp-alist): Augment.
+ (run-python): Import `emacs' module to Python rather than loading
+ code directly. Set python-buffer differently.
+ (python-send-region): Use emacs.eexecfile. Fix orig-start calculation.
+ Use python-proc.
+ (python-send-command): Go to end of comint buffer.
+ (python-load-file): Use python-proc, emacs.eimport.
+ (python-describe-symbol): Simplify interactive form.
+ Use emacs.help. Do use temp-buffer-show-hook.
+ Call print-help-return-message.
+ (hippie-exp): Require when compiling.
+ (python-preoutput-continuation): Use rx.
+
+ * diff-mode.el (diff-make-unified): Fix regexp.
+
+2004-05-06 Romain Francoise <romain@orebokech.com> (tiny change)
+
+ * ibuffer.el (ibuffer-redisplay-engine): Do not remove folded
+ filter groups from the buffer when rebuilding the Ibuffer buffer
+ and `ibuffer-show-empty-filter-groups' is nil.
+
+2004-05-06 Vinicius Jose Latorre <viniciusjl@ig.com.br>
+
+ * ps-print.el (ps-print-quote): Call ps-value-string.
+ (ps-setup): Call ps-comment-string.
+ (ps-value-string, ps-comment-string): New funs.
+
+2004-05-06 Juanma Barranquero <lektu@terra.es>
+
+ * ehelp.el (electric-help-command-loop): Check whether the last
+ character is visible, not (point-max).
+
+ * help-fns.el (help-argument-name): Default to bold; don't inherit
+ from font-lock-variable-name-face.
+ (help-do-arg-highlight): Grok also ARGth occurrences in the docstring.
+
+2004-05-05 Kenichi Handa <handa@m17n.org>
+
+ * descr-text.el (describe-char): Copy the character with text
+ properties and overlays into the first line, and call
+ describe-text-properties on it.
+
+2004-05-05 Stephen Eglen <stephen@anc.ed.ac.uk>
+
+ * iswitchb.el (iswitchb-global-map): Fix typo.
+ Remove unwanted ###autoloads from source file.
+
+2004-05-05 Lars Hansen <larsh@math.ku.dk>
+
+ * wdired.el (wdired-change-to-wdired-mode): Quote wdired-mode-hook
+ in run-hooks. Use substitute-command-keys in message.
+ (wdired-abort-changes): Add message.
+
+2004-05-03 Michael Mauger <mmaug@yahoo.com>
+
+ * emacs/lisp/progmodes/sql.el (sql-xemacs-p, sql-emacs19-p)
+ (sql-emacs20-p): Remove.
+ (sql-mode-syntax-table): Use shared GNU EMacs/XEmacs syntax.
+ (sql-builtin-face, sql-doc-face): Remove.
+ (sql-mode-ansi-font-lock-keywords)
+ (sql-mode-oracle-font-lock-keywords)
+ (sql-mode-postgres-font-lock-keywords)
+ (sql-mode-linter-font-lock-keywords)
+ (sql-mode-ms-font-lock-keywords)
+ (sql-mode-mysql-font-lock-keywords): Use standard fonts.
+ (sql-product-font-lock): Fix font-lock reset when font rules change.
+ (sql-highlight-product): Remove incorrect font-lock reset logic.
+
+2004-05-04 Jonathan Yavner <jyavner@member.fsf.org>
+
+ * ses.el (ses-set-parameter): Fix typo.
+
+2004-05-04 Kim F. Storm <storm@cua.dk>
+
+ * ido.el (ido-read-internal): Fix call to read-file-name for edit.
+ Must expand directory for completion to work; and don't mess with
+ process-environment.
+ (ido-read-file-name): If command has ido property, don't use ido
+ if value is ignore, or read as directory if value is dir.
+ Set ido ignore property for dired-do-rename command.
+
+2004-05-04 Juanma Barranquero <lektu@terra.es>
+
+ * ehelp.el (electric-help-command-loop, electric-help-undefined)
+ (electric-help-help): Check against unmapped commands.
+
+ * help-fns.el (help-argument-name): New face, inheriting from
+ font-lock-variable-name-face, to highlight function arguments in
+ `describe-function' and `describe-key'.
+ (help-do-arg-highlight): Auxiliary function to highlight a given
+ list of arguments in a string.
+ (help-highlight-arguments): Highlight the function arguments and
+ all uses of them in the docstring.
+ (describe-function-1): Use it. Do docstring output via `insert',
+ not 'princ', so text attributes are preserved.
+
+ * winner.el (winner-mode-map): Move `winner-undo' and
+ `winner-redo' to C-c <left> and C-c <right>, respectively (the
+ previous bindings conflict with `prev-buffer', `next-buffer').
+
+2004-05-03 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+
+ * textmodes/bibtex.el (bibtex-progress-message): Fix docstring.
+ (bibtex-entry-update): New command bound to C-c C-u.
+ (bibtex-text-in-string): Fix regexp.
+ (bibtex-assoc-of-regexp): Remove.
+ (bibtex-progress-message): Fix docstring.
+ (bibtex-inside-field): Use if.
+ (bibtex-assoc-regexp): New function.
+ (bibtex-format-entry): Make code more robust so that it formats
+ also old entries.
+ (bibtex-autokey-demangle-title): Merge with obsolete function
+ bibtex-assoc-of-regexp.
+ (bibtex-field-list): New function.
+ (bibtex-entry): Use bibtex-field-list.
+ (bibtex-parse-entry): Fix docstring.
+ (bibtex-print-help-message): Use bibtex-field-list.
+ (bibtex-make-field): Use bibtex-field-list.
+ (bibtex-entry-index): Bugfix. Return crossref key if required.
+ (bibtex-lessp): Fix docstring.
+
+2004-05-03 Luc Teirlinck <teirllm@auburn.edu>
+
+ * select.el (xselect-convert-to-string): Move comment to intended line.
+
+2004-05-03 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * toolbar/tool-bar.el (tool-bar-setup): Use lookup-key for
+ cut/copy/paste in case menu-bar-enable-clipboard is in effect.
+
+2004-05-03 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * term/x-win.el (x-clipboard-yank): Don't exit on error from
+ x-get-selection.
+
+2004-05-03 Jason Rumney <jasonr@gnu.org>
+
+ * makefile.nt: Remove.
+
+2004-05-03 Kim F. Storm <storm@cua.dk>
+
+ * emulation/cua-base.el (cua--update-indications): Fix last change.
+ (cua-mode): Deactivate mark when cua-mode is enabled.
+
+2004-05-02 Luc Teirlinck <teirllm@auburn.edu>
+
+ * select.el (xselect-convert-to-string): Bind `inhibit-read-only' to t.
+
+2004-05-03 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el (gud-watch, gdb-display-buffer)
+ (gdb-display-source-buffer, gdb-put-breakpoint-icon)
+ (gdb-remove-breakpoint-icons, gdb-assembler-custom): Look for
+ window over visible frames.
+ (gdb-goto-breakpoint): Make buffer display file at breakpoint.
+
+2004-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-gcpro): New var.
+ (compilation-fake-loc): Use it.
+ (compilation-forget-errors): Reset it.
+
+2004-05-02 Dan Nicolaescu <dann@ics.uci.edu>
+
+ * diff-mode.el (diff-header-face, diff-file-header-face):
+ Use min-colors.
+
+2004-05-02 Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+
+ * textmodes/bibtex.el (bibtex-sort-buffer): Remove error message.
+ (bibtex-clean-entry): Disentangle code.
+ (bibtex-realign): New function.
+ (bibtex-reformat): Use mapcar and bibtex-realign. Do not use
+ bibtex-beginning-of-first-entry and bibtex-skip-to-valid-entry.
+ Remove undocumented optional arg called-by-convert-alien.
+ (bibtex-convert-alien): Use bibtex-realign. Use bibtex-reformat
+ for sorting instead of bibtex-sort-buffer.
+
+2004-05-02 Eli Zaretskii <eliz@gnu.org>
+
+ * progmodes/compile.el (compilation-start): In the
+ no-async-subprocesses branch, call sit-for to give redisplay a
+ chance to show the updated process status in the mode line, and
+ fontify the buffer explicitly after the process exits.
+
+2004-05-01 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (python-compilation-line-number): Remove.
+ (python-compilation-regexp-alist): Don't use it any more.
+ (python-orig-start, python-input-filter): Remove.
+ (inferior-python-mode): Don't set up comint-input-filter-functions.
+ (python-send-region): Use compilation-fake-loc.
+
+ * progmodes/compile.el (compilation-messages-start): New var.
+ (compilation-mode): Don't setup next-error-function here.
+ (compilation-setup): Set it up here instead (for minor modes as well).
+ Make compilation-messages-start buffer local.
+ (compilation-next-error-function): Use it.
+ (compilation-forget-errors): Set compilation-messages-start.
+
+2004-05-01 Luc Teirlinck <teirllm@auburn.edu>
+
+ * ielm.el (ielm-prompt-read-only): Update docstring.
+
+ * comint.el (comint-prompt-read-only): Update docstring.
+ (comint-update-fence, comint-kill-whole-line)
+ (comint-kill-region): New functions.
+
+ * simple.el (kill-whole-line): Use "p" instead of "P" in
+ interactive form.
+
+2004-05-01 Juanma Barranquero <lektu@terra.es>
+
+ * help-fns.el (help-add-fundoc-usage): Use %S instead of %s to
+ format arglist so default values in CL-style argument lists are
+ correctly shown.
+
+2004-05-01 Jason Rumney <jasonr@gnu.org>
+
+ * term/w32-win.el (w32-drag-n-drop): Use x-dnd.el functions.
+
+2004-05-01 Kenichi Handa <handa@m17n.org>
+
+ * international/titdic-cnv.el (miscdic-convert): Don't generate a
+ quail file if it is up to date.
+
+2004-04-30 Juri Linkov <juri@jurta.org>
+
+ * cus-edit.el (custom-mode-map):
+ Add key binding `C-x C-s' to `Custom-save'.
+
+ * outline.el (outline-blank-line): New var.
+ (outline-next-preface, outline-show-heading)
+ (outline-end-of-subtree): Use it.
+
+ * dired-aux.el (dired-touch-initial): New fun.
+ (dired-do-chxxx): Call it for op-symbol `touch'.
+ (dired-diff): Use `dired-dwim-target-directory'
+ if current dired buffer has no buffer mark.
+
+ * bindings.el (propertized-buffer-identification):
+ Replace `(:weight bold)' by `Buffer-menu-buffer-face'.
+ Add C-M-arrow keys for consistency.
+
+ * files.el (confirm-kill-emacs):
+ Change group from top-level `emacs' to `convenience'.
+
+ * emacs-lisp/lisp.el (beginning-of-defun, end-of-defun):
+ Push mark on the first call of successive command calls.
+ (insert-pair): New fun created from `insert-parentheses' with
+ `open' and `close' arguments added. Enclose active regions
+ in paired characters. Compare adjacent characters syntax with
+ inserted characters syntax before inserting a space.
+ (insert-parentheses): Call `insert-pair' with ?\( ?\).
+
+ * delsel.el: Don't put `delete-selection' property
+ on `insert-parentheses' symbol to take advantage of
+ region handling in `insert-pair' function.
+ Suggested by Stephan Stahl <stahl@eos.franken.de>.
+
+2004-04-30 Kim F. Storm <storm@cua.dk>
+
+ * emulation/cua-base.el: Add support for changing cursor types;
+ based on patch from Michael Mauger.
+ (cua-normal-cursor-color, cua-read-only-cursor-color)
+ (cua-overwrite-cursor-color, cua-global-mark-cursor-color):
+ Customization cursor type and/or cursor color.
+ (cua--update-indications): Handle cursor type changes.
+ (cua-mode): Update cursor indications if enabled.
+
+ * menu-bar.el (menu-bar-options-menu): Change menu text for CUA.
+
+ * mouse.el (mouse-drag-copy-region): New defcustom.
+ (mouse-set-region, mouse-drag-region-1): Use it.
+
+ * simple.el (kill-ring-save): If region face background color is
+ unspecified (if no highlighting), show extent of fully visible
+ region even if transient-mark-mode is enabled.
+
+ * emulation/cua-base.el (cua--standard-movement-commands):
+ Add cua-scroll-up and cua-scroll-down.
+ (cua-scroll-up, cua-scroll-down): New commands.
+ (cua--init-keymaps): Remap scroll-up and scroll-down.
+
+ * emulation/cua-rect.el (cua--convert-rectangle-as):
+ New defmacro.
+ (cua-upcase-rectangle, cua-downcase-rectangle): Use it.
+ (cua-upcase-initials-rectangle, cua-capitalize-rectangle):
+ New commands (suggested by Jordan Breeding).
+
+2004-04-30 Juanma Barranquero <lektu@terra.es>
+
+ * smerge-mode.el (smerge-diff-switches): Fix typo in docstring.
+
+2004-04-30 Mario Lang <mlang@delysid.org>
+
+ * diff.el (diff-switches): Fix typo in docstring.
+
+2004-04-30 Alex Schroeder <alex@gnu.org>
+
+ * xml.el (xml-debug-print-internal): Don't add newline and
+ indentation to text nodes and write empty elements as empty tags
+ instead of opening and closing tags.
+ (xml-debug-print): Take optional indent-string argument.
+ (xml-print): Alias for xml-debug-print.
+
+2004-04-30 Glenn Morris <gmorris@ast.cam.ac.uk>
+
+ * progmodes/fortran.el (fortran-fill): Use local var `bol' rather
+ than duplicate call to `line-beginning-position'.
+
+ * progmodes/f90.el (f90-get-present-comment-type):
+ Return whitespace, as well as comment chars, for consistent filling
+ of comment blocks. Use `match-string-no-properties'.
+ (f90-break-line): Trim trailing whitespace when filling comments.
+
+2004-04-30 Dave Love <fx@gnu.org>
+
+ * calendar/diary-lib.el (diary-outlook-formats): New variable.
+ (diary-from-outlook-internal, diary-from-outlook)
+ (diary-from-outlook-gnus, diary-from-outlook-rmail):
+ New functions to import diary entries from Outlook-format
+ appointments in mail messages.
+
+2004-04-29 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/python.el (python-send-command): New fun.
+ (python-send-region, python-load-file): Use it.
+
+ * progmodes/compile.el (compilation-last-buffer): Add var alias.
+
+ * help-fns.el (help-C-file-name): Use new subr-name.
+ Prepend `src/' to the file name.
+ (help-C-source-directory, help-subr-name, help-find-C-source): Remove.
+ (describe-function-1, describe-variable): Only find a C source file
+ name if DOC is already loaded.
+
+ * help-mode.el (help-function-def, help-variable-def):
+ Use the new find-function-search-for-symbol functionality.
+ Allow FILE to be `C-source'.
+
+ * emacs-lisp/find-func.el (find-function-C-source-directory): New var.
+ (find-function-C-source): New fun.
+ (find-function-search-for-symbol): Use it.
+
+2004-03-29 Michael Mauger <mmaug@yahoo.com>
+
+ * progmodes/sql.el (sql-product-alist): Rename variable
+ `sql-product-support'. Add Postgres login parameters.
+ (sql-set-product, sql-product-feature): Update with renamed variable.
+ (sql-connect-postgres): Add username prompt.
+ (sql-imenu-generic-expression, sql-mode-font-lock-object-name):
+ Make patterns less product specific.
+ (sql-xemacs-p, sql-emacs19-p): Add flags for Emacs variants.
+ (sql-mode-abbrev-table): Modify initialization.
+ (sql-builtin-face): Add variable.
+ (sql-keywords-re): Add macro.
+ (sql-mode-ansi-font-lock-keywords): Update for ANSI-92.
+ (sql-mode-oracle-font-lock-keywords): Update for Oracle 9i.
+ (sql-mode-postgres-font-lock-keywords): Update for Postgres 7.3.
+ (sql-mode-mysql-font-lock-keywords): Update for MySql 4.0.
+ (sql-mode-linter-font-lock-keywords)
+ (sql-mode-ms-font-lock-keywords): Use `sql-keywords-re' macro.
+ (sql-mode-sybase-font-lock-keywords)
+ (sql-mode-informix-font-lock-keywords)
+ (sql-mode-interbase-font-lock-keywords)
+ (sql-mode-ingres-font-lock-keywords)
+ (sql-mode-solid-font-lock-keywords)
+ (sql-mode-sqlite-font-lock-keywords)
+ (sql-mode-db2-font-lock-keywords): Default to nil.
+ (sql-product-font-lock): Always highlight ANSI keywords.
+ (sql-add-product-keywords): Made similar to `font-lock-add-keywords'.
+ (sql-send-string): Add function.
+
+2004-04-29 Dave Love <fx@gnu.org>
+
+ * progmodes/cfengine.el (cfengine-beginning-of-defun)
+ (cfengine-end-of-defun): Ensure progress through buffer.
+
+ * info-look.el (cfengine-mode): Accept a terminal ().
+
+2004-04-29 Juri Linkov <juri@jurta.org>
+
+ * isearch.el (isearch-mode-map): Bind \C-w to isearch-yank-word
+ instead of isearch-yank-word-or-char. Add new key bindings for
+ isearch-yank-char to \C-f, and isearch-del-char to \C-b.
+ (isearch-del-char): New fun.
+ (isearch-forward, isearch-edit-string): Update docstring.
+ (isearch-yank-char): Doc fix.
+ (isearch-other-meta-char): Restore point after scrolling.
+
+ * progmodes/compile.el (compilation-context-lines): Add nil option
+ to disable compilation output window scrolling.
+ (compilation-set-window): Use it.
+
+ * outline.el (outline-next-preface, outline-show-heading):
+ Don't leave unhidden blank line before heading.
+ (outline-end-of-subtree): Include last newline into subtree.
+ (hide-entry): Leave point at beginning of heading instead of end.
+ (outline-up-heading): Push mark for the first call of successive
+ command calls.
+
+2004-04-28 Luc Teirlinck <teirllm@auburn.edu>
+
+ * comint.el (comint-prompt-read-only): New variable.
+ (comint-output-filter): Implement it.
+
+ * ielm.el (ielm-prompt-read-only, ielm-prompt): Update docstring.
+ (ielm-prompt-internal): New variable.
+ (ielm-font-lock-keywords): Remove irrelevant ielm-prompt keyword.
+ (ielm-send-input): Delete unused variable `buf'.
+ (ielm-eval-input): Use `ielm-prompt-internal'.
+ (inferior-emacs-lisp-mode): Use new variables
+ `comint-prompt-read-only' and `ielm-prompt-internal'.
+ Get rid of obsolete variable `directory-sep-char'.
+ (ielm): Use `zerop'.
+
+2004-04-29 John Paul Wallington <jpw@gnu.org>
+
+ * thumbs.el (toplevel): Require cl at compile time.
+ Remove conditional definitions of `ignore-errors' and `caddar'
+ because they occur at run time.
+
+2004-04-28 Nick Roberts <nickrob@gnu.org>
+
+ * progmodes/gdb-ui.el (gdb-frame-breakpoints-buffer)
+ (gdb-frame-assembler-buffer, gdb-frame-threads-buffer)
+ (gdb-frame-registers-buffer, gdb-frame-locals-buffer)
+ (gdb-frame-gdb-buffer, gdb-frame-stack-buffer): Use selected-window.
+
+ * progmodes/gud.el (gud-common-init): Throw an error if program is
+ already running under gdb.
+
+2004-04-28 John Paul Wallington <jpw@gnu.org>
+
+ * thumbs.el (thumbs-delete-images): Fix formatting of prompt.
+ (thumbs-show-image-num): Move assignment of
+ `thumbs-current-image-filename' within scope of `i'.
+ (thumbs-emboss-image): Don't use `evenp'.
+
+2004-04-28 Richard M. Stallman <rms@gnu.org>
+
+ * progmodes/compile.el (compilation-context-lines): Default now 0.
+
+2004-04-28 Juanma Barranquero <lektu@terra.es>
+
+ Use `time-less-p' from calendar/time-date.el instead of defining
+ custom versions of it.
+
+ * pcomplete.el (pcomplete-time-less-p): Remove.
+
+ * thumbs.el (time-less-p): Remove.
+
+ * calendar/timeclock.el (timeclock-time-less-p): Remove.
+ (timeclock-generate-report): Use `time-less-p'.
+
+ * emacs-lisp/autoload.el (autoload-before-p): Remove.
+ (update-file-autoloads, update-directory-autoloads): Use `time-less-p'.
+
+2004-04-28 Masatake YAMATO <jet@gyve.org>
+
+ * subr.el (remove-overlays): Make arguments optional.
+
+ * wid-edit.el (widget-specify-button): Put evaporate to the
+ overlay for sample.
+ (widget-specify-sample): Put evaporate to the overlay for sample.
+ (widget-specify-doc): Put evaporate to the overlay for documentation.
+
+2004-04-27 Jesper Harder <harder@ifa.au.dk>
+
+ * info.el (info-apropos): Make it an index node. Align node names
+ like makeinfo.
+
+2004-04-27 Eli Zaretskii <eliz@gnu.org>
+
+ * net/browse-url.el (browse-url-netscape-sentinel)
+ (browse-url-mozilla-sentinel, browse-url-galeon-sentinel)
+ (browse-url-epiphany-sentinel, browse-url-mosaic):
+ Use browse-url-*-program instead of a literal program name.
+
+2004-04-27 Kevin Ryde <user42@zip.com.au>
+
+ * eshell/em-alias.el:
+ * eshell/em-dirs.el:
+ * eshell/em-hist.el:
+ * eshell/em-unix.el: Add "(require 'eshell)", to get necessary
+ features when M-x customize-group loads modules before the main
+ eshell.el.
+
+2004-04-27 Matthew Mundell <matt@mundell.ukfsn.org>
+
+ * subr.el (momentary-string-display): Support EXIT-CHAR that is
+ either a character representation of an event or an event
+ description list.
+
+ * type-break.el: Capitalise Emacs and Lisp.
+ (type-break-good-break-interval, type-break-demo-boring-stats)
+ (type-break-terse-messages, type-break-file-name): New defcustoms.
+ (type-break-post-command-hook)
+ (type-break-warning-countdown-string): Quote variable names in doc.
+ (type-break-interval-start, type-break-auto-save-file-name): New vars.
+ (type-break-mode): Document type-break-good-break-interval and the
+ "session" file. Schedule break according to the session file.
+ Kill session file buffer on exit. Organise for save-some-buffers
+ to always save the session file.
+ (type-break-mode-line-message-mode, type-break-query-mode):
+ Uppercase arguments.
+ (type-break-file-time, type-break-file-keystroke-count, timep)
+ (type-break-choose-file, type-break-get-previous-time)
+ (type-break-get-previous-count): New defuns.
+ (type-break): Avoid break querying after a completed break in the
+ case where the query was initiated during user invocation of the
+ break. Optional terse messages.
+ Use type-break-good-break-interval if type-break-good-rest-interval is
+ nil. File the break time.
+ (type-break-schedule): New optional args for overriding the use of
+ the current time.
+ (type-break-cancel-time-warning-schedule): Avoid leftover warnings
+ after a break.
+ (type-break-check): File the keystroke count.
+ (type-break-do-query): Prevent a second query when the break is
+ interrupted. Optional terse message.
+ (type-break-keystroke-reset): Record the start of a typing interval.
+ (type-break-demo-boring): Optional terse messages. Display word
+ per minute and keystroke counts according to
+ type-break-demo-boring-stats.
+
+2004-04-27 Daniel M Coffman <coffmand@us.ibm.com> (tiny change)
+
+ * arc-mode.el (archive-maybe-copy): If ARCHIVE includes leading
+ directories, make sure they exist under archive-tmpdir.
+
+2004-04-27 Juri Linkov <juri@jurta.org>
+
+ * help.el (view-emacs-news): With argument, display info for the
+ selected version by finding it among different NEWS files, and
+ narrowing the buffer to the selected version.
+
+ * info.el: Add *info*<[0-9]+> to same-window-regexps instead of
+ same-window-buffer-names.
+ (info): New arg `buffer'. Use it. Doc fix. Read file name for
+ non-numeric prefix argument, append the number to the buffer name
+ for numeric prefix argument.
+ (info-other-window): Bind same-window-regexps to nil.
+ (Info-reference-name): Rename to Info-point-loc.
+ (Info-find-node-2): Call forward-line for numeric Info-point-loc,
+ and Info-find-index-name for stringy Info-point-loc.
+ (Info-extract-menu-node-name): New arg `index-node'. Use regexp
+ without middle `.', but with final `.' and optional line number
+ for it. Set Info-point-loc for index nodes.
+ (Info-index): Remove middle `.' from index entry regexp.
+ Modify line number regexp.
+ (Info-index-next): Decrement line number.
+ (info-apropos): Remove middle `.' from index entry regexp.
+ Add optional line number regexp at the end. Add matched value
+ for line number to the result list and insert it to the buffer.
+ Replace match-string by match-string-no-properties.
+ Reorder result list.
+ (Info-fontify-node): Hide index line numbers.
+ (Info-goto-node): Replace "\\s *\\'" by "\\s +\\'" to not trim
+ empty matches.
+ (Info-follow-reference): Use `str' instead of
+ Info-following-node-name-re.
+ (Info-toc): Use full file names. Set Info-current-node to "Top".
+ (Info-fontify-node): Compare file names without directory name.
+ (Info-try-follow-nearest-node): Don't set Info-reference-name.
+ Set second arg of Info-extract-menu-node-name for index nodes.
+ (info-xref-visited): Use magenta3 instead of magenta4.
+ (Info-mode): Add info-apropos to docstring.
+
+ * log-view.el (log-view-diff): Replace interactive code "r"
+ by a list to allow to call it even if region is not active.
+
+ * paren.el (show-paren-highlight-openparen): New var.
+ (show-paren-function): Turn on openparen highlighting when
+ matching forward if show-paren-highlight-openparen is non-nil.
+
+ * simple.el (kill-ring-save): Use blink-matching-delay instead of
+ the constant value 1.
+ (completions-common-part): Expand docstring.
+
+ * textmodes/picture.el (picture-mode-map): Add arrow keys.
+
+2004-04-27 Kim F. Storm <storm@cua.dk>
+
+ * image.el (insert-sliced-image): Use line-height instead of
+ line-spacing property on newline.
+
+2004-04-26 Lars Hansen <larsh@math.ku.dk>
+
+ * desktop.el (desktop-buffer-misc-data-function): Rename to
+ desktop-save-buffer and change docstring.
+ (desktop-buffer-modes-to-save): Delete.
+ (desktop-save-buffer-p): Use desktop-save-buffer instead of
+ desktop-buffer-modes-to-save.
+ (desktop-save): Rename desktop-buffer-misc-data-function to
+ desktop-save-buffer and allow non-function value.
+ (desktop-missing-file-warning): Correct docstring.
+
+ * dired.el (dired-mode): Rename desktop-buffer-misc-data-function
+ to desktop-save-buffer.
+
+ * info.el (Info-mode): Rename desktop-buffer-misc-data-function to
+ desktop-save-buffer.
+
+ * mail/rmail.el (rmail-variables): Bind desktop-save-buffer to t.
+
+ * mh-e/mh-e.el (mh-folder-mode): Bind desktop-save-buffer to t.
+
+2004-04-26 Eli Zaretskii <eliz@gnu.org>
+
+ * progmodes/gud.el (gud-pdb-command-name): Change default to "pydb".
+
+2004-04-25 Luc Teirlinck <teirllm@auburn.edu>
+
+ * ielm.el (ielm-prompt-read-only, ielm-prompt): Expand docstring.
+ (ielm): Only go to the end of the buffer when starting a new process.
+
+2004-04-25 Juanma Barranquero <lektu@terra.es>
+
+ * ielm.el (inferior-emacs-lisp-mode): Display working buffer on the
+ mode line. Bind `inhibit-read-only' to t before modifying
+ properties of text in the buffer.
+ (ielm): Force point to the end of buffer, even when running ielm
+ from inside itself.
+
+2004-04-25 Jesper Harder <harder@ifa.au.dk>
+
+ * info.el (info-apropos): Reset Info-complete-cache.
+
+2004-04-25 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compilation-error-regexp-alist-alist):
+ Also recognize severe Irix et al. messages.
+ (compilation-normalize-filename, compile-abbreviate-directory):
+ Delete functions.
+ (compilation-get-file-structure): New function inherits
+ functionality of the two preceding ones.
+ (compilation-internal-error-properties, compilation-fake-loc):
+ Use it so that different paths to the same file share the same
+ markers. Also optimize finding adjacent marker slightly.
+
+2004-04-25 Kim F. Storm <storm@cua.dk>
+
+ * image.el (insert-sliced-image): Add line-spacing t property
+ to newlines separating image lines.
+
+2004-04-24 Luc Teirlinck <teirllm@auburn.edu>
+
+ * comint.el (comint-delete-output): Bind inhibit-read-only to t.
+
+ * ielm.el (ielm-prompt-read-only): New user option.
+ (ielm-prompt): Expand docstring to describe new behavior.
+ (inferior-emacs-lisp-mode): Implement ielm-prompt-read-only and
+ mention it in the docstring.
+
+2004-04-24 Andreas Schwab <schwab@suse.de>
+
+ * progmodes/sh-script.el (sh-leading-keywords) <sh>: Add "!".
+
+ * diff.el (diff): Set default-directory in diff buffer.
+
+2004-04-24 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/sendmail.el (mail-bury): Don't delete the frame where the
+ mail was being composed if the terminal cannot display more than
+ one frame; instead, switch to previous frame.
+
+ * mail/rmail.el (rmail-mail-new-frame): Doc fix.
+ (rmail-start-mail): Support rmail-mail-new-frame even on
+ terminals that can display only one frame at a time.
+
+2004-04-23 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * emacs-lisp/checkdoc.el (checkdoc-output-error-regex-alist): New var.
+ (checkdoc-output-font-lock-keywords): Remove error regexp.
+ (checkdoc-output-mode-map): Remove.
+ (checkdoc-output-mode): Derive from compilation-mode.
+ (checkdoc-find-error-mouse, checkdoc-find-error): Remove.
+
+ * dired.el (dired-mode-map): Add a menu entry for wdired.
+
+ * emacs-lisp/rx.el (rx-syntax): Move sregex style syntax to code.
+ (rx-bracket, rx-check-any, rx-any): Clean up name space.
+
+ * wdired.el: (wdired-mode-map): Move init into declaration.
+ Fix `return' binding.
+ (wdired-change-to-wdired-mode, wdired-change-to-dired-mode):
+ Use force-mode-line-update.
+ (wdired-get-filename): Use `unless'.
+ (wdired-preprocess-files): Don't assume names have no \n and use / for
+ dir separator.
+ (wdired-normalize-filename): Use replace-regexp-in-string.
+ (wdired-load-hooks): Remove.
+ (wdired-mode-hooks): Rename to wdired-mode-hook.
+
+ * info-look.el: Add support for cfengine-mode.
+ (info-lookup-setup-mode): Use dolist.
+
+2004-04-23 Juan Le,As(Bn Lahoz Garc,Am(Ba <juan-leon.lahoz@tecsidel.es>
+
+ * wdired.el: New file.
+
+2004-04-23 Juanma Barranquero <lektu@terra.es>
+
+ * ielm.el (inferior-emacs-lisp-mode): Fix docstring.
+
+ * pcomplete.el (pcomplete-opt, pcomplete-actual-arg)
+ (pcomplete-match-string, pcomplete-comint-setup, pcomplete-here)
+ (pcomplete--help, pcomplete--here): Doc fixes.
+
+2004-04-23 Andre Spiegel <spiegel@gnu.org>
+
+ * vc-hooks.el (vc-default-workfile-unchanged-p): Fix code that
+ handles wrong-number-of-arguments in backend call.
+
+ * vc.el (vc-print-log): Likewise.
+
+2004-04-20 Dave Love <fx@gnu.org>
+
+ * emacs-lisp/rx.el: Doc fixes.
+ (rx-constituents): Add/extend many forms.
+ (rx-check): Check form is a list.
+ (bracket): Defvar.
+ (rx-check-any, rx-any, rx-check-not): Modify.
+ (rx-not): Simplify.
+ (rx-trans-forms, rx-=, rx->=, rx-**, rx-not-char, rx-not-syntax): New.
+ (rx-kleene): Use rx-trans-forms.
+ (rx-quote-for-set): Delete.
+ (rx): Allow multiple args.
+
+2004-04-23 Kenichi Handa <handa@m17n.org>
+
+ * international/mule-util.el (char-displayable-p): Simplify by
+ using internal-char-font.
+
+2004-04-23 Juanma Barranquero <lektu@terra.es>
+
+ * makefile.w32-in: Add "-*- makefile -*-" mode tag.
+
+2004-04-22 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * diff-mode.el (diff-next-error): New fun.
+ (diff-mode): Use it.
+
+ * simple.el (next-error): Change arg name.
+ Add support for the documented C-u C-x ` usage.
+
+ * frame.el (special-display-popup-frame, next-multiframe-window)
+ (previous-multiframe-window): Only consider frames on same display.
+
+2004-04-22 Lars Hansen <larsh@math.ku.dk>
+
+ * info.el (Info-restore-desktop-buffer): Delete with-no-warnings.
+ * mh-e/mh-e.el (mh-restore-desktop-buffer): Delete with-no-warnings.
+
+2004-04-22 Kim F. Storm <storm@cua.dk>
+
+ * net/telnet.el (telnet): Add optional port arg.
+
+2004-04-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-mode-font-lock-keywords):
+ Minor sanity check on the `hyperlink' slot.
+
+ * Makefile.in (recompile): Compile new files.
+
+ * emacs-lisp/bytecomp.el (batch-byte-recompile-directory):
+ Add byte-recompile-directory's optional `arg'.
+
+ * cvs-status.el (cvs-tree-use-charset): New var.
+ (cvs-tree-char-space, cvs-tree-char-hbar, cvs-tree-char-vbar)
+ (cvs-tree-char-branch, cvs-tree-char-eob, cvs-tree-char-bob)
+ (cvs-status-cvstrees): Use it.
+
+ * emacs-lisp/checkdoc.el (checkdoc-output-mode):
+ Make it a normal major mode.
+ (checkdoc-buffer-label): Make sure the file name is meaningful.
+ (checkdoc-output-to-error-buffer): Remove.
+ (checkdoc-error, checkdoc-start-section): Rewrite.
+
+ * info.el (info-node, info-menu-5, info-xref, info-header-node)
+ (Info-title-1-face, Info-title-2-face, Info-title-3-face)
+ (Info-title-4-face): Use new syntax.
+ (info-xref-visited): Inherit from info-xref.
+
+ * progmodes/python.el (python-maybe-jython): Don't assume point-min==1.
+
+2004-04-21 Teodor Zlatanov <tzz@lifelogs.com>
+
+ * simple.el (next-error-last-buffer, next-error-function):
+ New variables for the next-error framework.
+ (next-error-buffer-p): New function.
+ (next-error-find-buffer): Generalize compilation-find-buffer.
+ (next-error, previous-error, first-error, next-error-no-select)
+ (previous-error-no-select): Move from compile.el.
+
+ * replace.el (occur-next-error, occur-1): Hook into the next-error
+ framework.
+
+ * progmodes/compile.el (compilation-start):
+ Set next-error-last-buffer so next-error knows where to jump.
+ (compilation-setup): Set the buffer-local variable
+ next-error-function to 'compilation-next-error-function.
+ (compilation-buffer-p, compilation-buffer-internal-p): Use an
+ alternate way to find if a buffer is a compilation buffer, for
+ next-error convenience.
+ (next-error-no-select, previous-error-no-select, next-error)
+ (previous-error, first-error): Move to simple.el.
+ (compilation-find-buffer): Move to next-error-find-buffer in simple.el.
+ (compilation-last-buffer): Remove.
+ (compilation-start, compilation-next-error, compilation-setup)
+ (compilation-next-error-function, compilation-find-buffer):
+ Remove compilation-last-buffer use.
+
+2004-04-21 Juanma Barranquero <lektu@terra.es>
+
+ * font-lock.el (font-lock-preprocessor-face): Remove spurious quote.
+ (font-lock-warning-face): Fix spacing.
+
+ * makefile.w32-in (WINS): Add url/ directory.
+
+2004-04-21 Lars Hansen <larsh@math.ku.dk>
+
+ * desktop.el (desktop-buffer-mode-handlers): New variable.
+ Alist of major mode specific functions to restore a desktop buffer.
+ (desktop-buffer-handlers): Make variable obsolete.
+ (desktop-create-buffer): Use desktop-buffer-mode-handlers.
+ Catch errors signaled in handlers. Update buffer count.
+ Evaluate desktop-buffer-point.
+ (desktop-buffer-dired): Rename to dired-restore-desktop-buffer and
+ move to dired.el.
+ (desktop-buffer-info): Rename to Info-restore-desktop-buffer and
+ move to info.el.
+ (desktop-buffer-rmail): Rename to rmail-restore-desktop-buffer and
+ move to mail/rmail.el.
+ (desktop-buffer-mh): Rename to mh-restore-desktop-buffer and move
+ to mh-e/mh-e.el.
+ (desktop-buffer-file): Rename to desktop-restore-file-buffer.
+ On fail, print message (to message buffer) even if
+ desktop-missing-file-warning is nil.
+ (desktop-buffer-misc-data-function): New buffer local variable.
+ Function returning major mode specific data.
+ (desktop-buffer-misc-functions): Make variable obsolete.
+ (desktop-save): Use desktop-buffer-misc-data-function.
+ (desktop-buffer-dired-misc-data): Rename to
+ dired-desktop-buffer-misc-data and move to dired.el.
+ (desktop-buffer-info-misc-data): Rename to
+ Info-desktop-buffer-misc-data and move to info.el.
+ (desktop-read): Add message about number of buffers restored/failed.
+
+ * dired.el (dired-restore-desktop-buffer) Move from desktop.el.
+ Add parameters. Pause to display error only when
+ desktop-missing-file-warning is non-nil.
+ (dired-desktop-buffer-misc-data): Move from desktop.el. Add parameter.
+ (dired-mode): Bind desktop-buffer-misc-data-function.
+
+ * info.el (Info-restore-desktop-buffer): Move from desktop.el.
+ Add Parameters.
+ (Info-desktop-buffer-misc-data): Move from desktop.el. Add parameter.
+ (Info-mode): Bind desktop-buffer-misc-data-function.
+
+ * mail/rmail.el (rmail-restore-desktop-buffer): Move from desktop.el.
+ Add Parameters.
+
+ * mh-e/mh-e.el (mh-restore-desktop-buffer): Move from desktop.el.
+ Add Parameters.
+
+2003-04-21 Paul Pogonyshev <pogonyshev@gmx.net>
+
+ * dabbrev.el (dabbrev--substitute-expansion): Don't lose
+ the case of letters in case-insensitive expansions when the
+ abbrev is preceded by characters with letter syntax.
+
+2004-04-21 Richard M. Stallman <rms@gnu.org>
+
+ * progmodes/cperl-mode.el (cperl-putback-char):
+ Delete Emacs 18 definition.
+
+ * international/mule.el (ctext-post-read-conversion):
+ Use assoc-string, not assoc-ignore-case.
+
+ * international/mule-cmds.el: Use assoc-string, not assoc-ignore-case.
+
+ * emacs-lisp/easymenu.el (easy-menu-add):
+ Do call x-popup-menu, but only if it's defined.
+
+ * emacs-lisp/disass.el (disassemble): Handle lambda-exp as arg.
+
+ * emacs-lisp/bytecomp.el (byte-compile-no-warnings):
+ Handle multiple args: compile like progn.
+
+ * emacs-lisp/byte-run.el (with-no-warnings): Simplify:
+ take all args as &rest arg.
+
+ * autoinsert.el (auto-insert-alist): Insert the user's name in
+ copyright notice, rather than Free Software Foundation.
+
+2004-04-21 Kenichi Handa <handa@m17n.org>
+
+ * descr-text.el (describe-char): Make it work on *Help* buffer.
+
+2004-04-21 Kim F. Storm <storm@cua.dk>
+
+ * image.el (insert-image): Add optional SLICE arg.
+ (insert-sliced-image): New defun.
+
+2004-04-20 Lawrence Mitchell <wence@gmx.li> (tiny change)
+
+ * subr.el (read-number): Check whether `default' is nil.
+
+2004-04-20 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * progmodes/compile.el (compilation-error-properties):
+ Split into two.
+ (compilation-internal-error-properties): New one.
+ (compilation-compat-error-properties): Use it. Fix the non-marker case.
+
+2004-04-20 Richard M. Stallman <rms@gnu.org>
+
+ * window.el (split-window-save-restore-data):
+ Don't update the data if OLD-INFO is nil.
+
+ * view.el (view-return-to-alist): Mark it permanent local.
+
+ * subr.el (event-modifiers): Fix the criterion for ASCII control chars.
+
+ * recentf.el (recentf-save-list): Catch and warn about errors.
+
+ * menu-bar.el (menu-bar-update-buffers): Call copy-sequence
+ so "Buffers" won't be pure.
+
+ * help-mode.el (help-mode-finish): Set help-return-alist first
+ thing, setting only the entry for the selected window.
+
+ * help-fns.el (describe-function-1): If many non-control non-meta
+ keys run the command, don't list all of them.
+
+2004-04-20 Juanma Barranquero <lektu@terra.es>
+
+ * vc-svn.el (vc-svn-print-log, vc-svn-diff): Add optional BUFFER
+ arg. Copied from Andre Spiegel's patch of 2004-03-21.
+
+ * calendar/time-date.el (time-to-day-in-year): Fix docstring.
+
+2004-04-20 Kenichi Handa <handa@m17n.org>
+
+ * international/quail.el (quail-lookup-key): New optional arg
+ NOT-RESET-INDICES.
+ (quail-get-translations): Call quail-lookup-key with
+ NOT-RESET-INDICES t.
+ (quail-completion): Likewise.
+ (quail-lookup-map-and-concat): Likewise.
+
+2004-04-20 Kenichi Handa <handa@m17n.org>
+
+ * international/quail.el (quail-update-translation): Don't insert
+ such an unsupported multibyte char in a unibyte buffer.
+
+2004-04-20 Nick Roberts <nick@nick.uklinux.net>
+
+ * progmodes/gdb-ui.el (gdb-frame-parameters): New constant.
+ (gdb-frame-breakpoints-buffer, gdb-frame-stack-buffer)
+ (gdb-frame-threads-buffer, gdb-frame-registers-buffer)
+ (gdb-frame-locals-buffer, gdb-frame-gdb-buffer)
+ (gdb-frame-assembler-buffer): Improve behaviour with
+ multiple frames.
+ (gdb-display-buffer): Extend search to all visible frames.
+
+2004-04-19 Eli Zaretskii <eliz@gnu.org>
+
+ * mail/rmail.el (rmail-convert-to-babyl-format): Don't remove ^M
+ characters left after base64 decoding.
+ (rmail-decode-region): Use -dos variety of `coding', to remove any
+ ^M characters left after qp or base64 decoding.
+
+2004-04-19 Jan Dj,Ad(Brv <jan.h.d@swipnet.se>
+
+ * x-dnd.el (x-dnd-open-local-file, x-dnd-open-file): Improve error
+ messages.
+
+2004-04-19 Stephen Eglen <stephen@gnu.org>
+
+ * add-log.el (add-change-log-entry): Update doc string to mention
+ add-log-full-name and add-log-mailing-address.
+
+2004-04-18 Juri Linkov <juri@jurta.org>
+
+ * info.el (Info-find-file, Info-find-node-2): Add history and toc.
+ (Info-find-node-2): Simplify error message.
+ (Info-insert-dir): Use Info-following-node-name.
+ (Info-goto-node): Remove *info-history* and *info-toc*.
+ (Info-history): Create a node of the virtual history file.
+ (Info-toc): Create a node of the virtual toc file.
+ (Info-insert-toc): New arg `curr-file' for reference file names.
+ (info-apropos): Remove redundant var binding for temp-file.
+ (Info-index, Info-index-next, Info-mode): Doc fix.
+ (Info-goto-emacs-command-node): Don't jump to *info* from
+ non-*info* Info buffers.
+ (Info-fontify-node): Don't show the file name of external
+ references if `Info-hide-note-references' is `hide'. Don't hide
+ newlines at the end of paragraphs.
+
+ * international/mule-diag.el (list-input-methods):
+ Fix args to help-xref-button.
+
+ * help-fns.el (help-with-tutorial): Call `hack-local-variables'
+ to put into effect local variables from TUTORIAL files.
+
+ * textmodes/paragraphs.el (sentence-end) <function>: New fun
+ with default value taken from the variable `sentence-end'.
+ (sentence-end) <defcustom>: Set default to nil. Doc fix.
+ Add nil const to :type.
+ (sentence-end-without-period, sentence-end-double-space)
+ (sentence-end-without-space): Doc fix.
+
+ * textmodes/paragraphs.el (forward-sentence):
+ * textmodes/fill.el (canonically-space-region, fill-nobreak-p)
+ (fill-delete-newlines):
+ * progmodes/cc-cmds.el (c-beginning-of-statement):
+ Use function `sentence-end' instead of variable `sentence-end'.
+
+2004-04-18 Andreas Schwab <schwab@suse.de>
+
+ * progmodes/compile.el (compilation-start): Set window start to
+ point-min if compilation-scroll-output is nil.
+
+2004-04-18 John Wiegley <johnw@newartisans.com>
+
+ * iswitchb.el (iswitchb-completions): Remove dependency on cl.
+
+2004-04-18 Nick Roberts <nick@nick.uklinux.net>
+
+ * progmodes/gdb-ui.el (gdb-goto-info): Require 'info.
+ (gdb-info-breakpoints-custom): Revert previous change.
+ (gdb-view-assembler): Update assembler if necessary.
+ (gdb-frame-handler): Parse correctly for gdb-current-frame.
+ (gdb-display-source-buffer): Update properly when both source and
+ assembler are visible.
+
+2004-04-17 John Wiegley <johnw@newartisans.com>
+
+ * iswitchb.el (iswitchb-max-to-show): Add a new config variable
+ which limits the number of names shown in the minibuffer. Off by
+ default.
+ (iswitchb-completions): Use `iswitchb-max-to-show'. This speeds
+ up iswitchb for users with a multitude of open buffers by showing
+ only the first and last N/2 buffers in the completion list (which
+ is enough to aid C-s/C-r, and to know that more characters are
+ needed to refine the completion list).
+
+2004-04-17 Richard M. Stallman <rms@gnu.org>
+
+ * files.el (locate-file-completion): Handle nil in path-and-suffixes.
+ (file-truename): Expand all ~ constructs directly.
+ (insert-directory): Delete any error msg output by the
+ `insert-directory-program'.
+
+ * allout.el (allout-mode-exposure-menu, allout-mode-editing-menu):
+ (allout-mode-navigation-menu, allout-mode-misc-menu): New defvars.
+ (allout-prior-bindings, allout-added-bindings): Defvars deleted.
+ (allout-init): Use find-file-hook, not find-file-hooks.
+ (allout-mode): Eliminate Emacs 18 support.
+ Use write-contents-functions, not local-write-file-hooks.
+
+2004-04-17 Daniel Pfeiffer <occitan@esperanto.org>
+
+ * progmodes/compile.el (compilation-error-properties): Fix for
+ adding messages when there are already markers for their file.
+ (compilation-fake-loc): New function.
+
+2004-04-16 Dave Love <fx@gnu.org>
+
+ * progmodes/python.el (python-compilation-line-number): Fix braindamage.
+ (python-load-file): Fix python-orig-start setting.
+
+ * progmodes/compile.el: Doc fixes.
+ (compilation-error-regexp-alist-alist)
+ (compilation-mode-font-lock-keywords): Allow non-ASCII where possible.
+ (compilation-assq): Wrap in eval-when-compile.
+ (compilation-mode-font-lock-keywords): Don't use list*.
+ (compilation-start): Avoid warning.
+ (compilation-compat-error-properties)
+ (compilation-directory-properties): Add keymap property.
+ (compilation-parsing-end): Make it a marker for better compatibility.
+
+ * progmodes/python.el (python-after-info-look): Use with-no-warnings.
+
+2004-04-16 Mark A. Hershberger <mah@everybody.org>
+
+ * xml.el: Doc fixes.
+ (xml-get-children): Only looks at sub-tags and ignore strings.
+
+ * xml.el (xml-parse-tag): Avoid overwriting node-name.
+
+2004-04-16 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * url/url-util.el (url-debug): Use with-current-buffer.
+
+ * url/url-nfs.el (url-nfs-file-attributes): Add id-format parameter.
+ (url-nfs-create-wrapper): Use new backquote syntax.
+
+ * url/url-https.el (url-https-file-attributes): Add id-format param.
+
+ * url/url-http.el (url-http-head-file-attributes)
+ (url-http-file-attributes): Add id-format parameter.
+
+ * url/url-handlers.el: Use new find-file-hook.
+ (url-file-attributes): Add id-format parameter.
+
+ * url/url-file.el (url-file-create-wrapper): Use new backquote syntax.
+ (url-file-file-attributes): Add id-format parameter.
+
+ * url/url-dav.el: Use with-current-buffer.
+ (url-dav-process-response): Fix regexps and spurious quote.
+ (url-dav-file-attributes): Add id-format param.
+
+ * diff-mode.el (diff-end-of-hunk): Be more careful with unified hunks.
+
+2004-04-16 Andre Spiegel <spiegel@gnu.org>
+
+ * vc-hooks.el (vc-default-workfile-unchanged-p): Quote signal.
+
+ * vc.el (vc-print-log): Likewise.
+
+2004-04-16 Masatake YAMATO <jet@gyve.org>
+
+ * simple.el (completion-setup-function): Set an initial value
+ to `element-common-end' before entering loop. Set a value
+ to `element-common-end' at the end of loop.
+ The bug is reported by Juri Linkov <juri@jurta.org> in emacs-devel list.
+ (completions-common-part): Rename from completion-de-emphasis.
+ (completions-first-difference): Rename from completion-emphasis.
+ Suggested by RMS.
+
+2004-04-16 Juanma Barranquero <lektu@terra.es>
+
+ * bookmark.el (bookmark-send-edited-annotation): Fix docstring.
+ (bookmark-edit-annotation-mode): Add mode name.
+
+2004-04-15 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * smerge-mode.el (smerge-match-conflict): Try to do something sensible
+ for nested conflict markers.
+ (smerge-find-conflict): Better handle errors in smerge-match-conflict.
+
+2004-04-15 Nick Roberts <nick@nick.uklinux.net>
+
+ * progmodes/gdb-ui.el (gdb-goto-info): New function.
+
+ * progmodes/gud.el (gud-menu-map, gud-tool-bar-map): Add help button.
+
2004-04-14 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/bytecomp.el (batch-byte-compile-file):
@@ -91,7 +2802,7 @@
in addition it also disables menu-bar, tool-bar, scroll-bars,
tool-tips, and the blinking cursor.
(command-line-1): Skip startup screen if -Q.
- (fancy-splash-head): Use :align-to center prop to center splash image.
+ (fancy-splash-head): Use ":align-to center" prop to center splash image.
* emulation/cua-base.el (cua-read-only-cursor-color)
(cua-overwrite-cursor-color, cua-global-mark-cursor-color): Doc fix.
@@ -126,6 +2837,10 @@
* progmodes/python.el (run-python): Use compilation-shell-minor-mode.
Set compilation-error-regexp-alist earlier.
+ * progmodes/compile.el (compilation-minor-mode-map)
+ (compilation-shell-minor-mode-map, compile-mouse-goto-error)
+ (compile-goto-error): Re-merge the mouse and non-mouse commands.
+
2004-04-12 Stefan Monnier <monnier@iro.umontreal.ca>
* progmodes/compile.el (compile-goto-error): Select the buffer/window
@@ -288,7 +3003,7 @@
2004-04-08 Nick Roberts <nick@nick.uklinux.net>
- * progmodes/gdb-ui.el (gdb-source-window): Remove variable
+ * progmodes/gdb-ui.el (gdb-source-window): Remove variable.
(gdb-goto-breakpoint, gdb-display-buffer)
(gdb-display-source-buffer, gdb-view-source-function)
(gdb-view-assembler, gdb-setup-windows, gdb-restore-windows)
@@ -327,7 +3042,8 @@
Use Info-search-whitespace-regexp. Set Info-search-case-fold.
(Info-search-case-sensitively, Info-search-next): New fun.
(Info-up): Move point to the menu item of the current node.
- (Info-history): New fun. Add *info-history* to same-window-buffer-names.
+ (Info-history): New fun. Add *info-history* to
+ same-window-buffer-names.
(Info-toc): New fun. Add *info-toc* to same-window-buffer-names.
(Info-insert-toc): New fun.
(Info-build-toc): New fun.
@@ -375,19 +3091,6 @@
* help-mode.el (help-function-def, help-variable-def): Handle hyperrefs
to C source files specially.
-2004-04-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * progmodes/compile.el: Require CL.
- (compilation-mode-font-lock-keywords): Re-install the "line as
- function" patch.
-
- * help-fns.el (help-C-source-directory): New var.
- (help-subr-name, help-C-file-name, help-find-C-source): New funs.
- (describe-function-1, describe-variable): Use them.
-
- * help-mode.el (help-function-def, help-variable-def): Handle hyperrefs
- to C source files specially.
-
2004-04-07 Jan Nieuwenhuizen <janneke@gnu.org>
* info.el (Info-hide-cookies-node): New function.
@@ -424,7 +3127,7 @@
2004-04-05 Vinicius Jose Latorre <viniciusjl@ig.com.br>
- * printing.el: Dox fix.
+ * printing.el: Doc fix.
2004-04-05 Nick Roberts <nick@nick.uklinux.net>
@@ -667,14 +3370,14 @@
* progmodes/gdb-ui.el (gdb-ann3, gdb-send-item)
(gud-gdba-marker-filter): Log the process input and output, if
- required. (from Stefan Monnier)
+ required. From Stefan Monnier.
(gdb-debug-log, gdb-enable-debug-log): New variables.
(gdb-post-prompt): Don't do gdb-var-update on Mac OS X.
2004-03-28 Stefan Monnier <monnier@iro.umontreal.ca>
* vc-hooks.el (vc-file-not-found-hook): Fix typo.
- From lorentey@elte.hu (L,Bu(Brentey K,Ba(Broly).
+ From lorentey@elte.hu (L$,1 q(Brentey K,Aa(Broly).
2004-03-27 Luc Teirlinck <teirllm@auburn.edu>
@@ -989,7 +3692,7 @@
if the source location can't be found.
(edebug-compute-previous-result): Use prin1-char.
- * emacs-lisp/checkdoc.el (checkdoc-error): Dont' assume point-min == 1.
+ * emacs-lisp/checkdoc.el (checkdoc-error): Don't assume point-min == 1.
(debug-ignored-errors): Add an entry.
* emacs-lisp/bytecomp.el (byte-recompile-directory): Ignore hidden dir.
@@ -1026,7 +3729,7 @@
2004-03-21 Andre Spiegel <spiegel@gnu.org>
- * vc.el Add new optional BUFFER argument to vc-BACKEND-print-log
+ * vc.el: Add new optional BUFFER argument to vc-BACKEND-print-log
and vc-BACKEND-diff.
(vc-print-log): If the print-log implementation supports it, use
the new BUFFER argument to direct output to *vc-change-log*, not *vc*.
@@ -1505,7 +4208,7 @@
* printing.el: Replace "As Is..." in PostScript file print/preview by
"No Preprocessing...". Suggested by Colin Marquardt
- <marquardt@zmd.de>.
+ <_marquardt_@zmd.de>.
(pr-insert-section-4): Adjust buffer interface.
2004-02-29 Kai Grossjohann <kai.grossjohann@gmx.net>
@@ -1590,7 +4293,7 @@
(top-level): Require password.el if visible. Should be mandatory
once No Gnus has found its way into (X)Emacs.
(tramp-read-passwd): Invoke `password-read' if available,
- `read-passwd' otherwise. `ange-ftp-read-passwd' isn't used as
+ `read-passwd' otherwise. `ange-ftp-read-passwd' isn't used as
fallback any longer.
(tramp-clear-passwd): New function.
(tramp-process-actions, tramp-process-multi-actions):
@@ -3012,7 +5715,7 @@
* gdb-ui.el (gdb-prompt): Change filter for level 3 annotations,
if necessary.
- (gdb-ann3): New function. Initialise M-x gdb as for M-x gdba if
+ (gdb-ann3): New function. Initialise M-x gdb as for M-x gdba if
annotations are detected.
(gud-gdba-marker-filter): Use global variable gud-marker-acc
instead of a local one to allow transition from
@@ -3106,7 +5809,7 @@
* gdb-ui.el (gdba, gdb-assembler-mode): Call the mode "Machine" as
a mode called "Assembler" already exists.
(gdb-use-colon-colon-notation, gdb-show-changed-values): New options.
- (gud-watch): Use format option. Remove font properties from string.
+ (gud-watch): Use format option. Remove font properties from string.
(gdb-var-create-handler, gdb-var-list-children-handler):
Don't bother about properties as there are none.
(gdb-var-create-handler, gdb-var-list-children-handler)
@@ -3199,7 +5902,7 @@
(tramp-handle-file-attributes): Replace proprietary optional
parameter NONNUMERIC by the recently (Emacs 21.4) introduced ID-FORMAT.
(tramp-handle-file-attributes-with-perl): Handle parameter
- NONNUMERIC if set. This wasn't done in the past.
+ NONNUMERIC if set. This wasn't done in the past.
(tramp-post-connection): Apply second parameter "$2" if
`tramp-remote-perl' is called.
@@ -3973,7 +6676,7 @@
* progmodes/gud.el (gud-menu-map, gud-tool-bar-map):
Replace gud-display with gud-watch.
(gud-speedbar-buttons): Add stuff for watching expressions
- in the speedbar when using M-x gdba. Use dolist on old part
+ in the speedbar when using M-x gdba. Use dolist on old part
of this function.
* gdb-ui.el (gdb-var-list, gdb-var-changed, gdb-update-flag)
@@ -4208,9 +6911,9 @@
* ffap.el (ffap-shell-prompt-regexp): Add regexp to identify
common shell prompts that are not common filename or URL characters.
(ffap-file-at-point): Use the new regexp to strip the prompts from
- the file names. This is an issue mostly for user prompts that
+ the file names. This is an issue mostly for user prompts that
don't have a trailing space and find-file-at-point is invoked from
- within a shell inside emacs.
+ within a shell inside Emacs.
2003-09-24 Andre Spiegel <spiegel@gnu.org>
@@ -4425,7 +7128,7 @@
* gdb-ui.el (gud-display1): Use gud-call to prevent extra prompt
being displayed in GUD buffer.
- (gdb-idle-input-queue): Remove var. Use just one queue.
+ (gdb-idle-input-queue): Remove var. Use just one queue.
(gdb-enqueue-idle-input,gdb-dequeue-idle-input):
Remove functions. Use just one queue.
(gdb-prompt, gdb-subprompt, def-gdb-auto-update-trigger)
@@ -4609,7 +7312,7 @@
2003-08-24 Nick Roberts <nick@nick.uklinux.net>
* progmodes/gud.el (gud-display-line): Don't set window-point if
- source buffer is not visible. (Only happens with M-x gdba).
+ source buffer is not visible. (Only happens with M-x gdba.)
* gdb-ui.el (gdba): Remove gdb-quit (previously removed) from
documentation.
@@ -4857,7 +7560,7 @@
2003-08-12 Juri Linkov <juri@jurta.org> (tiny change)
* simple.el (backward-word, forward-to-indentation)
- (backward-to-indentation): Argument changed to optional.
+ (backward-to-indentation): Argument changed to optional.
(next-line, previous-line): Use `or' instead of `unless'.
2003-08-12 Vinicius Jose Latorre <viniciusjl@ig.com.br>
@@ -5039,7 +7742,7 @@
behaviour of `calendar-day-name' and `calendar-month-name' functions.
(diary-name-pattern): Use abbrev arrays, rather than fixing
abbrevs at three chars. Calling syntax change.
- (mark-diary-entries): Adapt for new behaviours of
+ (mark-diary-entries): Adapt for new behaviours of
`diary-name-pattern' and `calendar-make-alist' functions.
(fancy-diary-font-lock-keywords): Adapt for new behaviour of
`diary-name-pattern' function.
@@ -5426,7 +8129,7 @@
2003-07-10 Vinicius Jose Latorre <viniciusjl@ig.com.br>
* ps-print.el: Print line number correctly in a region. Reported by
- Tim Allen <timallen@ls83.fsnet.co.uk>
+ Tim Allen <timallen@ls83.fsnet.co.uk>.
(ps-print-version): New version number (6.6.2).
(ps-printing-region): Code fix.
@@ -5490,7 +8193,7 @@
2003-07-08 Markus Rost <rost@math.ohio-state.edu>
- * subr.el (dolist, dotimes): Doc fix.
+ * subr.el (dolist, dotimes): Doc fix.
2003-07-08 Kim F. Storm <storm@cua.dk>
@@ -5648,33 +8351,33 @@
(bibtex-autokey-get-names): Fiddle with regexps.
(bibtex-generate-autokey): Use identity.
(bibtex-parse-keys): Use simplified parsing algorithm if
- bibtex-parse-keys-fast is non-nil. Simplify. Change order of
- arguments. Return alist of keys.
- (bibtex-parse-strings): Simplify. Return alist of strings.
+ bibtex-parse-keys-fast is non-nil. Simplify. Change order of
+ arguments. Return alist of keys.
+ (bibtex-parse-strings): Simplify. Return alist of strings.
(bibtex-complete-string-cleanup): Fix docstring.
(bibtex-read-key): New function.
- (bibtex-mode): Fix docstring. Do not parse for keys and
- strings when the mode is entered. Set fill-paragraph-function to
- bibtex-fill-field. Setup font-lock-mark-block-function the way
+ (bibtex-mode): Fix docstring. Do not parse for keys and
+ strings when the mode is entered. Set fill-paragraph-function to
+ bibtex-fill-field. Setup font-lock-mark-block-function the way
font-lock intended.
- (bibtex-entry): Use bibtex-read-key. Obey bibtex-autofill-types.
+ (bibtex-entry): Use bibtex-read-key. Obey bibtex-autofill-types.
(bibtex-parse-entry, bibtex-autofill-entry): New functions.
(bibtex-print-help-message, bibtex-remove-OPT-or-ALT)
(bibtex-Preamble): Avoid hard coded constants.
- (bibtex-make-field): Fix docstring. Simplify.
+ (bibtex-make-field): Fix docstring. Simplify.
(bibtex-beginning-of-entry): Always return new position of point.
(bibtex-end-of-entry): Rearrange cond clauses.
(bibtex-count-entries, bibtex-validate, bibtex-reformat):
Update for changes of bibtex-map-entries.
(bibtex-ispell-abstract): Do not move point.
- (bibtex-entry-index): Use downcase. Simplify.
+ (bibtex-entry-index): Use downcase. Simplify.
(bibtex-lessp): Handle catch-all.
(bibtex-find-crossref): Turn into a command.
- (bibtex-find-entry): Simplify. Use bibtex-read-key. Fix regexp.
- (bibtex-clean-entry): Use bibtex-read-key. Handle string and
+ (bibtex-find-entry): Simplify. Use bibtex-read-key. Fix regexp.
+ (bibtex-clean-entry): Use bibtex-read-key. Handle string and
preamble entries.
(bibtex-fill-field-bounds): New function.
- (bibtex-fill-field): New command. Bound to fill-paragraph-function.
+ (bibtex-fill-field): New command. Bound to fill-paragraph-function.
(bibtex-fill-entry): Use bibtex-fill-field-bounds
(bibtex-String): Use bibtex-strings. Always obey
bibtex-sort-ignore-string-entries.
@@ -5782,7 +8485,7 @@ See ChangeLog.10 for earlier changes.
;; coding: iso-2022-7bit
;; End:
- Copyright (C) 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2001, 02, 04 Free Software Foundation, Inc.
Copying and distribution of this file, with or without modification,
are permitted provided the copyright notice and this notice are preserved.
diff --git a/lisp/ChangeLog.10 b/lisp/ChangeLog.10
index 6aae7e44cdf..cf1743c3490 100644
--- a/lisp/ChangeLog.10
+++ b/lisp/ChangeLog.10
@@ -8320,17 +8320,27 @@
indicating source of entry to add-to-diary-list.
(diary-button-face, diary-entry, diary-goto-entry): New, to
support click to diary file.
- (fancy-diary-display): Buttonize diary entries.
+ (fancy-diary-display): Buttonize diary entries. Use new mode
+ fancy-diary-display-mode.
(list-sexp-diary-entries): Pass a marker indicating source of
entry to add-to-diary-list.
(diary-date): Return mark as well as entry.
+ (add-to-diary-list): Add new marker argument, appended to
+ diary-entries-list.
+ (diary-mode, fancy-diary-display-mode): New derived modes, for
+ diary file and fancy diary buffer respectively.
+ (fancy-diary-font-lock-keywords, diary-font-lock-keywords): New
+ variables.
+ (font-lock-diary-sexps, font-lock-diary-date-forms): New
+ functions, used in diary-font-lock-keywords.
* calendar/calendar.el (diary-face): New.
(european-calendar-display-form, describe-calendar-mode)
(mark-visible-calendar-date, calendar-mark-today): Tidy doc string.
- (calendar-make-alist): New.
- (calendar-mode): Set up font-lock mode.
+ (calendar-mode): Set up font-lock mode, using new variable
+ calendar-font-lock-keywords.
(generate-calendar-window): Fontify if font-lock-mode is on.
+ (calendar-font-lock-keywords): New variable.
2002-11-16 Ivan Zakharyaschev <imz@altlinux.org> (tiny change)
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index e1db260776b..d43f47871c2 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -279,7 +279,7 @@ compile-after-backup: backup-compiled-files compile-always
# .elc is present.
recompile: doit $(lisp)/progmodes/cc-mode.elc
- LC_ALL=C $(EMACS) $(EMACSOPT) -f batch-byte-recompile-directory $(lisp)
+ LC_ALL=C $(EMACS) $(EMACSOPT) --eval "(batch-byte-recompile-directory 0)" $(lisp)
# CC Mode uses a compile time macro system which causes a compile time
# dependency in cc-mode.elc on the macros in cc-langs.el and the
@@ -324,5 +324,4 @@ bootstrap-after: finder-data custom-deps
distclean:
-rm -f ./Makefile
-# arch-tag: d4ea703a-b91c-405c-a171-8dde30b163a7
# Makefile ends here.
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index 1e3eea0e359..3be0014fd0e 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -37,9 +37,9 @@ define global abbrevs instead."
:group 'convenience)
(defun abbrev-mode (&optional arg)
- "Toggle abbrev mode.
+ "Toggle Abbrev mode in the current buffer.
With argument ARG, turn abbrev mode on iff ARG is positive.
-In abbrev mode, inserting an abbreviation causes it to expand
+In Abbrev mode, inserting an abbreviation causes it to expand
and be replaced by its expansion."
(interactive "P")
(setq abbrev-mode
@@ -48,18 +48,19 @@ and be replaced by its expansion."
(force-mode-line-update))
(defcustom abbrev-mode nil
- "Toggle abbrev mode.
+ "Enable or disable Abbrev mode.
Non-nil means automatically expand abbrevs as they are inserted.
+Setting this variable with `setq' changes it for the current buffer.
Changing it with \\[customize] sets the default value.
-Use the command `abbrev-mode' to enable or disable Abbrev mode in the current
-buffer."
+Interactively, use the command `abbrev-mode'
+to enable or disable Abbrev mode in the current buffer."
:type 'boolean
:group 'abbrev-mode)
(defvar edit-abbrevs-map nil
- "Keymap used in edit-abbrevs.")
+ "Keymap used in `edit-abbrevs'.")
(if edit-abbrevs-map
nil
(setq edit-abbrevs-map (make-sparse-keymap))
diff --git a/lisp/add-log.el b/lisp/add-log.el
index 609dfde5f65..3c29e8a465e 100644
--- a/lisp/add-log.el
+++ b/lisp/add-log.el
@@ -230,13 +230,13 @@ Note: The search is conducted only within 10%, at the beginning of the file."
;; Possibly further names in a list:
("\\=, \\([^ ,:([\n]+\\)" nil nil (1 'change-log-file-face))
;; Possibly a parenthesized list of names:
- ("\\= (\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face))
- ("\\=, *\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face)))
+ ("\\= (\\([^) ,\n]+\\)" nil nil (1 'change-log-list-face))
+ ("\\=, *\\([^) ,\n]+\\)" nil nil (1 'change-log-list-face)))
;;
;; Function or variable names.
- ("^\t(\\([^) ,:\n]+\\)"
+ ("^\t(\\([^) ,\n]+\\)"
(1 'change-log-list-face)
- ("\\=, *\\([^) ,:\n]+\\)" nil nil (1 'change-log-list-face)))
+ ("\\=, *\\([^) ,\n]+\\)" nil nil (1 'change-log-list-face)))
;;
;; Conditionals.
("\\[!?\\([^]\n]+\\)\\]\\(:\\| (\\)" (1 'change-log-conditionals-face))
@@ -445,7 +445,7 @@ Optional arg BUFFER-FILE overrides `buffer-file-name'."
(defun add-change-log-entry (&optional whoami file-name other-window new-entry)
"Find change log file, and add an entry for today and an item for this file.
Optional arg WHOAMI (interactive prefix) non-nil means prompt for user
-name and site.
+name and email (stored in `add-log-full-name' and `add-log-mailing-address').
Second arg FILE-NAME is file name of the change log.
If nil, use the value of `change-log-default-name'.
diff --git a/lisp/allout.el b/lisp/allout.el
index 3fa04449e16..dd4495cfa84 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -1,6 +1,6 @@
;;; allout.el --- extensive outline mode for use alone and with other modes
-;; Copyright (C) 1992, 1993, 1994, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 1992, 93, 94, 2001, 02, 2004 Free Software Foundation, Inc.
;; Author: Ken Manheimer <klm@zope.com>
;; Maintainer: Ken Manheimer <klm@zope.com>
@@ -46,7 +46,7 @@
;;
;; The outline menubar additions provide quick reference to many of
;; the features, and see the docstring of the function `allout-init'
-;; for instructions on priming your emacs session for automatic
+;; for instructions on priming your Emacs session for automatic
;; activation of `allout-mode'.
;;
;; See the docstring of the variables `allout-layout' and
@@ -83,7 +83,7 @@ dictated by `allout-layout' should be imposed on mode activation.
With value t, auto-mode-activation and auto-layout are enabled.
\(This also depends on `allout-find-file-hook' being installed in
-`find-file-hooks', which is also done by `allout-init'.)
+`find-file-hook', which is also done by `allout-init'.)
With value `ask', auto-mode-activation is enabled, and endorsement for
performing auto-layout is asked of the user each time.
@@ -162,7 +162,7 @@ prefix, which is concluded by bullets that includes the value of this
var and the respective allout-*-bullets-string vars.
The value of an asterisk (`*') provides for backwards compatibility
-with the original emacs outline mode. See `allout-plain-bullets-string'
+with the original Emacs outline mode. See `allout-plain-bullets-string'
and `allout-distinctive-bullets-string' for the range of available
bullets."
:type 'string
@@ -263,7 +263,7 @@ from regular comments that start at bol.")
Non-nil restricts the topic creation and modification
functions to asterix-padded prefixes, so they look exactly
-like the original emacs-outline style prefixes.
+like the original Emacs-outline style prefixes.
Whatever the setting of this variable, both old and new style prefixes
are always respected by the topic maneuvering functions."
@@ -491,7 +491,7 @@ those that do not have the variable `comment-start' set. A value of
(defcustom allout-inhibit-protection nil
"*Non-nil disables warnings and confirmation-checks for concealed-text edits.
-Outline mode uses emacs change-triggered functions to detect unruly
+Outline mode uses Emacs change-triggered functions to detect unruly
changes to concealed regions. Set this var non-nil to disable the
protection, potentially increasing text-entry responsiveness a bit.
@@ -507,7 +507,7 @@ behavior."
;;;_ : Version
;;;_ = allout-version
(defvar allout-version
- (let ((rcs-rev "$Revision: 1.47 $"))
+ (let ((rcs-rev "$Revision$"))
(condition-case err
(save-match-data
(string-match "Revision: \\([0-9]+\\.[0-9]+\\)" rcs-rev)
@@ -708,7 +708,7 @@ Works with respect to `allout-plain-bullets-string' and
(defvar allout-mode-map nil "Keybindings for (allout) outline minor mode.")
;;;_ > produce-allout-mode-map (keymap-alist &optional base-map)
(defun produce-allout-mode-map (keymap-list &optional base-map)
- "Produce keymap for use as allout-mode-map, from keymap-list.
+ "Produce keymap for use as allout-mode-map, from KEYMAP-LIST.
Built on top of optional BASE-MAP, or empty sparse map if none specified.
See doc string for allout-keybindings-list for format of binding list."
@@ -726,17 +726,12 @@ See doc string for allout-keybindings-list for format of binding list."
(car (cdr cell)))))))
keymap-list)
map))
-;;;_ = allout-prior-bindings - being deprecated.
-(defvar allout-prior-bindings nil
- "Variable for use in V18, with `allout-added-bindings', for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
-;;;_ = allout-added-bindings - being deprecated
-(defvar allout-added-bindings nil
- "Variable for use in V18, with `allout-prior-bindings', for
-resurrecting, on mode deactivation, bindings that existed before
-activation. Being deprecated.")
+
;;;_ : Menu bar
+(defvar allout-mode-exposure-menu)
+(defvar allout-mode-editing-menu)
+(defvar allout-mode-navigation-menu)
+(defvar allout-mode-misc-menu)
(defun produce-allout-mode-menubar-entries ()
(require 'easymenu)
(easy-menu-define allout-mode-exposure-menu
@@ -909,7 +904,7 @@ mode from prop-line file-var activation. Used by `allout-mode' function
to track repeats.")
;;;_ > allout-write-file-hook ()
(defun allout-write-file-hook ()
- "In `allout-mode', run as a `local-write-file-hooks' activity.
+ "In `allout-mode', run as a `write-contents-functions' activity.
Currently just sets `allout-during-write-cue', so outline change-protection
knows to keep inactive during file write."
@@ -944,17 +939,17 @@ MODE is one of the following symbols:
- anything else \(eg, t) for auto-activation and auto-layout, without
any confirmation check.
-Use this function to setup your emacs session for automatic activation
+Use this function to setup your Emacs session for automatic activation
of allout outline mode, contingent to the buffer-specific setting of
the `allout-layout' variable. (See `allout-layout' and
`allout-expose-topic' docstrings for more details on auto layout).
`allout-init' works by setting up (or removing)
-`allout-find-file-hook' in `find-file-hooks', and giving
+`allout-find-file-hook' in `find-file-hook', and giving
`allout-auto-activation' a suitable setting.
-To prime your emacs session for full auto-outline operation, include
-the following two lines in your emacs init file:
+To prime your Emacs session for full auto-outline operation, include
+the following two lines in your Emacs init file:
\(require 'allout)
\(allout-init t)"
@@ -979,16 +974,16 @@ the following two lines in your emacs init file:
(curr-mode 'allout-auto-activation))
(cond ((not mode)
- (setq find-file-hooks (delq hook find-file-hooks))
+ (setq find-file-hook (delq hook find-file-hook))
(if (interactive-p)
(message "Allout outline mode auto-activation inhibited.")))
((eq mode 'report)
- (if (memq hook find-file-hooks)
+ (if (memq hook find-file-hook)
;; Just punt and use the reports from each of the modes:
(allout-init (symbol-value curr-mode))
(allout-init nil)
(message "Allout outline mode auto-activation inhibited.")))
- (t (add-hook 'find-file-hooks hook)
+ (t (add-hook 'find-file-hook hook)
(set curr-mode ; `set', not `setq'!
(cond ((eq mode 'activate)
(message
@@ -1049,7 +1044,7 @@ Below is a description of the bindings, and then explanation of
special `allout-mode' features and terminology. See also the outline
menubar additions for quick reference to many of the features, and see
the docstring of the function `allout-init' for instructions on
-priming your emacs session for automatic activation of `allout-mode'.
+priming your Emacs session for automatic activation of `allout-mode'.
The bindings are dictated by the `allout-keybindings-list' and
@@ -1107,7 +1102,7 @@ C-c = p allout-flatten-exposed-to-buffer
Like above 'copy-exposed', but convert topic
prefixes to section.subsection... numeric
format.
-ESC ESC (allout-init t) Setup emacs session for outline mode
+ESC ESC (allout-init t) Setup Emacs session for outline mode
auto-activation.
HOT-SPOT Operation
@@ -1137,7 +1132,7 @@ twice in a row to get to the hot-spot.
Topic hierarchy constituents - TOPICS and SUBTOPICS:
-TOPIC: A basic, coherent component of an emacs outline. It can
+TOPIC: A basic, coherent component of an Emacs outline. It can
contain other topics, and it can be subsumed by other topics,
CURRENT topic:
The visible topic most immediately containing the cursor.
@@ -1252,19 +1247,6 @@ OPEN: A topic that is not closed, though its offspring or body may be."
; active state or *de*activation
; specifically requested:
(setq allout-explicitly-deactivated t)
- (if (string-match "^18\." emacs-version)
- ; Revoke those keys that remain
- ; as we set them:
- (let ((curr-loc (current-local-map)))
- (mapcar (function
- (lambda (cell)
- (if (eq (lookup-key curr-loc (car cell))
- (car (cdr cell)))
- (define-key curr-loc (car cell)
- (assq (car cell) allout-prior-bindings)))))
- allout-added-bindings)
- (allout-resumptions 'allout-added-bindings)
- (allout-resumptions 'allout-prior-bindings)))
(if allout-old-style-prefixes
(progn
@@ -1273,9 +1255,9 @@ OPEN: A topic that is not closed, though its offspring or body may be."
(allout-resumptions 'selective-display)
(if (and (boundp 'before-change-functions) before-change-functions)
(allout-resumptions 'before-change-functions))
- (setq local-write-file-hooks
- (delq 'allout-write-file-hook
- local-write-file-hooks))
+ (setq write-contents-functions
+ (delq 'allout-write-file-hook
+ write-contents-functions))
(allout-resumptions 'paragraph-start)
(allout-resumptions 'paragraph-separate)
(allout-resumptions (if (string-match "^18" emacs-version)
@@ -1315,20 +1297,13 @@ OPEN: A topic that is not closed, though its offspring or body may be."
(cons '(allout-mode . allout-mode-map)
minor-mode-map-alist))))
- ; V18 minor-mode key bindings:
- ; Stash record of added bindings
- ; for later revocation:
- (allout-resumptions 'allout-added-bindings
- (list allout-keybindings-list))
- (allout-resumptions 'allout-prior-bindings
- (list (current-local-map)))
; and add them:
(use-local-map (produce-allout-mode-map allout-keybindings-list
(current-local-map)))
)
; selective-display is the
- ; emacs conditional exposure
+ ; Emacs conditional exposure
; mechanism:
(allout-resumptions 'selective-display '(t))
(if allout-inhibit-protection
@@ -1340,7 +1315,7 @@ OPEN: A topic that is not closed, though its offspring or body may be."
; Temporarily set by any outline
; functions that can be trusted to
; deal properly with concealed text.
- (add-hook 'local-write-file-hooks 'allout-write-file-hook)
+ (add-hook 'write-contents-functions 'allout-write-file-hook)
; Custom auto-fill func, to support
; respect for topic headline,
; hanging-indents, etc:
@@ -1562,7 +1537,7 @@ Actually, returns prefix beginning point."
(defun allout-sibling-index (&optional depth)
"Item number of this prospective topic among its siblings.
-If optional arg depth is greater than current depth, then we're
+If optional arg DEPTH is greater than current depth, then we're
opening a new level, and return 0.
If less than this depth, ascend to that depth and count..."
@@ -1647,8 +1622,7 @@ Return the location of the beginning of the heading, or nil if not found."
"Produce a location \"chart\" of subtopics of the containing topic.
Optional argument LEVELS specifies the depth \(relative to start
-depth) for the chart. Subsequent optional args are not for public
-use.
+depth) for the chart.
Charts are used to capture outline structure, so that outline altering
routines need assess the structure only once, and then use the chart
@@ -1661,9 +1635,11 @@ list containing, recursively, the charts for the respective subtopics.
The chart for a topics' offspring precedes the entry for the topic
itself.
-The other function parameters are for internal recursion, and should
-not be specified by external callers. ORIG-DEPTH is depth of topic at
-starting point, and PREV-DEPTH is depth of prior topic."
+\(fn &optional levels)"
+
+ ;; The other function parameters are for internal recursion, and should
+ ;; not be specified by external callers. ORIG-DEPTH is depth of topic at
+ ;; starting point, and PREV-DEPTH is depth of prior topic."
(let ((original (not orig-depth)) ; `orig-depth' set only in recursion.
chart curr-depth)
@@ -1677,7 +1653,7 @@ starting point, and PREV-DEPTH is depth of prior topic."
;; Loop over the current levels' siblings. Besides being more
;; efficient than tail-recursing over a level, it avoids exceeding
- ;; the typically quite constrained emacs max-lisp-eval-depth.
+ ;; the typically quite constrained Emacs max-lisp-eval-depth.
;;
;; Probably would speed things up to implement loop-based stack
;; operation rather than recursing for lower levels. Bah.
@@ -1766,36 +1742,36 @@ start point."
(setq chart (cdr chart))))
result))
;;;_ X allout-chart-spec (chart spec &optional exposing)
-(defun allout-chart-spec (chart spec &optional exposing)
- "Not yet \(if ever) implemented.
-
-Produce exposure directives given topic/subtree CHART and an exposure SPEC.
-
-Exposure spec indicates the locations to be exposed and the prescribed
-exposure status. Optional arg EXPOSING is an integer, with 0
-indicating pending concealment, anything higher indicating depth to
-which subtopic headers should be exposed, and negative numbers
-indicating (negative of) the depth to which subtopic headers and
-bodies should be exposed.
-
-The produced list can have two types of entries. Bare numbers
-indicate points in the buffer where topic headers that should be
-exposed reside.
-
- - bare negative numbers indicates that the topic starting at the
- point which is the negative of the number should be opened,
- including their entries.
- - bare positive values indicate that this topic header should be
- opened.
- - Lists signify the beginning and end points of regions that should
- be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
- exposure:"
- (while spec
- (cond ((listp spec)
- )
- )
- (setq spec (cdr spec)))
- )
+;; (defun allout-chart-spec (chart spec &optional exposing)
+;; "Not yet \(if ever) implemented.
+
+;; Produce exposure directives given topic/subtree CHART and an exposure SPEC.
+
+;; Exposure spec indicates the locations to be exposed and the prescribed
+;; exposure status. Optional arg EXPOSING is an integer, with 0
+;; indicating pending concealment, anything higher indicating depth to
+;; which subtopic headers should be exposed, and negative numbers
+;; indicating (negative of) the depth to which subtopic headers and
+;; bodies should be exposed.
+
+;; The produced list can have two types of entries. Bare numbers
+;; indicate points in the buffer where topic headers that should be
+;; exposed reside.
+
+;; - bare negative numbers indicates that the topic starting at the
+;; point which is the negative of the number should be opened,
+;; including their entries.
+;; - bare positive values indicate that this topic header should be
+;; opened.
+;; - Lists signify the beginning and end points of regions that should
+;; be flagged, and the flag to employ. (For concealment: `\(\?r\)', and
+;; exposure:"
+;; (while spec
+;; (cond ((listp spec)
+;; )
+;; )
+;; (setq spec (cdr spec)))
+;; )
;;;_ - Within Topic
;;;_ > allout-goto-prefix ()
@@ -2163,7 +2139,7 @@ Changes to concealed regions are ignored while file is being written.
writes, like crypt and zip modes.)
Locally bound in outline buffers to `before-change-functions', which
-in emacs 19 is run before any change to the buffer.
+in Emacs 19 is run before any change to the buffer.
Any functions which set [`this-command' to `undo', or which set]
`allout-override-protect' non-nil (as does, eg, allout-flag-chars)
@@ -2178,7 +2154,7 @@ are exempt from this restriction."
; Both beginning and end chars must
; be exposed:
(save-excursion (if (memq this-command '(newline open-line))
- ;; Compensate for stupid emacs {new,
+ ;; Compensate for stupid Emacs {new,
;; open-}line display optimization:
(setq beg (1+ beg)
end (1+ end)))
@@ -2190,7 +2166,7 @@ are exempt from this restriction."
(save-match-data
(if (equal this-command 'undo)
;; Allow undo without inhibition.
- ;; - Undoing new and open-line hits stupid emacs redisplay
+ ;; - Undoing new and open-line hits stupid Emacs redisplay
;; optimization (em 19 cmds.c, ~ line 200).
;; - Presumably, undoing what was properly protected when
;; done.
@@ -2356,7 +2332,7 @@ return to regular interpretation of self-insert characters."
(let* ((this-key-num (cond
((numberp last-command-char)
last-command-char)
- ;; XXX Only xemacs has characterp.
+ ;; XXX Only XEmacs has characterp.
((and (fboundp 'characterp)
(characterp last-command-char))
(char-to-int last-command-char))
@@ -2410,7 +2386,7 @@ Called as part of `allout-post-command-business'."
;;;_ > allout-flag-region (from to flag)
(defmacro allout-flag-region (from to flag)
- "Hide or show lines from FROM to TO, via emacs selective-display FLAG char.
+ "Hide or show lines from FROM to TO, via Emacs selective-display FLAG char.
Ie, text following flag C-m \(carriage-return) is hidden until the
next C-j (newline) char.
@@ -2423,7 +2399,7 @@ Returns the endpoint of the region."
;;;_ > allout-isearch-expose (mode)
(defun allout-isearch-expose (mode)
- "Mode is either 'clear, 'start, 'continue, or 'final."
+ "MODE is either 'clear, 'start, 'continue, or 'final."
;; allout-isearch-prior-pos encodes exposure status of prior pos:
;; (pos was-vis header-pos end-pos)
;; pos - point of concern
@@ -2532,7 +2508,7 @@ Offer one suitable for current depth DEPTH as default."
)
;;;_ > allout-distinctive-bullet (bullet)
(defun allout-distinctive-bullet (bullet)
- "True if bullet is one of those on `allout-distinctive-bullets-string'."
+ "True if BULLET is one of those on `allout-distinctive-bullets-string'."
(string-match (regexp-quote bullet) allout-distinctive-bullets-string))
;;;_ > allout-numbered-type-prefix (&optional prefix)
(defun allout-numbered-type-prefix (&optional prefix)
@@ -2704,7 +2680,7 @@ index for each successive sibling)."
)
;;;_ > allout-open-topic (relative-depth &optional before use_sib_bullet)
(defun allout-open-topic (relative-depth &optional before use_sib_bullet)
- "Open a new topic at depth DEPTH.
+ "Open a new topic at depth RELATIVE-DEPTH.
New topic is situated after current one, unless optional flag BEFORE
is non-nil, or unless current line is complete empty (not even
@@ -2925,7 +2901,7 @@ Maintains outline hanging topic indentation if
(do-auto-fill))))
;;;_ > allout-reindent-body (old-depth new-depth &optional number)
(defun allout-reindent-body (old-depth new-depth &optional number)
- "Reindent body lines which were indented at old-depth to new-depth.
+ "Reindent body lines which were indented at OLD-DEPTH to NEW-DEPTH.
Optional arg NUMBER indicates numbering is being added, and it must
be accommodated.
@@ -2999,15 +2975,13 @@ Note that refill of indented paragraphs is not done."
"Adjust bullet of current topic prefix.
-All args are optional.
-
If SOLICIT is non-nil, then the choice of bullet is solicited from
user. If it's a character, then that character is offered as the
default, otherwise the one suited to the context \(according to
distinction or depth) is offered. If non-nil, then the
context-specific bullet is just used.
-Second arg DEPTH forces the topic prefix to that depth, regardless
+Second arg NEW-DEPTH forces the topic prefix to that depth, regardless
of the topic's current depth.
Third arg NUMBER-CONTROL can force the prefix to or away from
@@ -3120,13 +3094,13 @@ With repeat count, shift topic depth by that amount."
contained subtopics. See `allout-rebullet-heading' for rebulleting
behavior.
-All arguments are optional.
-
-First arg RELATIVE-DEPTH means to shift the depth of the entire
+Arg RELATIVE-DEPTH means to shift the depth of the entire
topic that amount.
-The rest of the args are for internal recursive use by the function
-itself. The are STARTING-DEPTH, STARTING-POINT, and INDEX."
+\(fn &optional RELATIVE-DEPTH)"
+
+ ;; All args except the first one are for internal recursive use by the
+ ;; function itself.
(let* ((relative-depth (or relative-depth 0))
(new-depth (allout-depth))
@@ -3925,11 +3899,7 @@ Examples:
max-pos)))
;;;_ > allout-old-expose-topic (spec &rest followers)
(defun allout-old-expose-topic (spec &rest followers)
-
- "Deprecated. Use `allout-expose-topic' \(with different schema
-format) instead.
-
-Dictate wholesale exposure scheme for current topic, according to SPEC.
+ "Dictate wholesale exposure scheme for current topic, according to SPEC.
SPEC is either a number or a list. Optional successive args
dictate exposure for subsequent siblings of current topic.
@@ -3956,7 +3926,7 @@ dictates the exposure depth of the topic as a whole. Subsequent
elements of the list are nested SPECs, dictating the specific exposure
for the corresponding offspring of the topic.
-Optional FOLLOWER arguments dictate exposure for succeeding siblings."
+Optional FOLLOWERS arguments dictate exposure for succeeding siblings."
(interactive "xExposure spec: ")
(let ((depth (allout-current-depth))
@@ -4001,6 +3971,9 @@ Optional FOLLOWER arguments dictate exposure for succeeding siblings."
(allout-old-expose-topic (car followers))
(setq followers (cdr followers)))
max-pos))
+(make-obsolete 'allout-old-expose-topic
+ "use `allout-expose-topic' (with different schema format) instead."
+ "19.23")
;;;_ > allout-new-exposure '()
(defmacro allout-new-exposure (&rest spec)
"Literal frontend for `allout-expose-topic', doesn't evaluate arguments.
@@ -4031,9 +4004,7 @@ Examples:
(list 'allout-expose-topic (list 'quote spec))))
;;;_ > allout-exposure '()
(defmacro allout-exposure (&rest spec)
- "Being deprecated - use more recent `allout-new-exposure' instead.
-
-Literal frontend for `allout-old-expose-topic', doesn't evaluate arguments
+ "Literal frontend for `allout-old-expose-topic', doesn't evaluate arguments
and retains start position."
(list 'save-excursion
'(if (not (or (allout-goto-prefix)
@@ -4041,6 +4012,7 @@ and retains start position."
(error "Can't find any outline topics"))
(cons 'allout-old-expose-topic
(mapcar (function (lambda (x) (list 'quote x))) spec))))
+(make-obsolete 'allout-exposure 'allout-new-exposure "19.23")
;;;_ #7 Systematic outline presentation - copying, printing, flattening
@@ -4248,12 +4220,10 @@ header and body. The elements of that list are:
;;;_ > allout-process-exposed (&optional func from to frombuf
;;; tobuf format)
(defun allout-process-exposed (&optional func from to frombuf tobuf
- format &optional start-num)
+ format start-num)
"Map function on exposed parts of current topic; results to another buffer.
-All args are options; default values itemized below.
-
-Apply FUNCTION to exposed portions FROM position TO position in buffer
+Apply FUNC to exposed portions FROM position TO position in buffer
FROMBUF to buffer TOBUF. Sixth optional arg, FORMAT, designates an
alternate presentation form:
@@ -4266,7 +4236,7 @@ alternate presentation form:
except for distinctive bullets.
Defaults:
- FUNCTION: `allout-insert-listified'
+ FUNC: `allout-insert-listified'
FROM: region start, if region active, else start of buffer
TO: region end, if region active, else end of buffer
FROMBUF: current buffer
@@ -4311,11 +4281,13 @@ Defaults:
(defun allout-insert-listified (listified)
"Insert contents of listified outline portion in current buffer.
-Listified is a list representing each topic header and body:
+LISTIFIED is a list representing each topic header and body:
\`(depth prefix text)'
-or \`(depth prefix text bullet-plus)'
+or
+
+ \`(depth prefix text bullet-plus)'
If `bullet-plus' is specified, it is inserted just after the entire prefix."
(setq listified (cdr listified))
@@ -4381,14 +4353,14 @@ alternate presentation format for the outline:
(defun allout-flatten-exposed-to-buffer (&optional arg tobuf)
"Present numeric outline of outline's exposed portions in another buffer.
-The resulting outline is not compatable with outline mode - use
+The resulting outline is not compatible with outline mode - use
`allout-copy-exposed-to-buffer' if you want that.
Use `allout-indented-exposed-to-buffer' for indented presentation.
With repeat count, copy the exposed portions of only current topic.
-Other buffer has current buffers name with \" exposed\" appended to
+Other buffer has current buffer's name with \" exposed\" appended to
it, unless optional second arg TOBUF is specified, in which case it is
used verbatim."
(interactive "P")
@@ -4397,22 +4369,22 @@ used verbatim."
(defun allout-indented-exposed-to-buffer (&optional arg tobuf)
"Present indented outline of outline's exposed portions in another buffer.
-The resulting outline is not compatable with outline mode - use
+The resulting outline is not compatible with outline mode - use
`allout-copy-exposed-to-buffer' if you want that.
Use `allout-flatten-exposed-to-buffer' for numeric sectional presentation.
With repeat count, copy the exposed portions of only current topic.
-Other buffer has current buffers name with \" exposed\" appended to
+Other buffer has current buffer's name with \" exposed\" appended to
it, unless optional second arg TOBUF is specified, in which case it is
used verbatim."
(interactive "P")
(allout-copy-exposed-to-buffer arg tobuf 'indent))
;;;_ - LaTeX formatting
-;;;_ > allout-latex-verb-quote (str &optional flow)
-(defun allout-latex-verb-quote (str &optional flow)
+;;;_ > allout-latex-verb-quote (string &optional flow)
+(defun allout-latex-verb-quote (string &optional flow)
"Return copy of STRING for literal reproduction across latex processing.
Expresses the original characters \(including carriage returns) of the
string across latex processing."
@@ -4422,7 +4394,7 @@ string across latex processing."
(concat "\\char" (number-to-string char) "{}"))
((= char ?\n) "\\\\")
(t (char-to-string char)))))
- str
+ string
""))
;;;_ > allout-latex-verbatim-quote-curr-line ()
(defun allout-latex-verbatim-quote-curr-line ()
@@ -4443,12 +4415,12 @@ environment. Leaves point at the end of the line."
(insert "\\")
(setq end (1+ end))
(goto-char (1+ (match-end 0))))))
-;;;_ > allout-insert-latex-header (buf)
-(defun allout-insert-latex-header (buf)
+;;;_ > allout-insert-latex-header (buffer)
+(defun allout-insert-latex-header (buffer)
"Insert initial latex commands at point in BUFFER."
;; Much of this is being derived from the stuff in appendix of E in
;; the TeXBook, pg 421.
- (set-buffer buf)
+ (set-buffer buffer)
(let ((doc-style (format "\n\\documentstyle{%s}\n"
"report"))
(page-numbering (if allout-number-pages
@@ -4517,10 +4489,10 @@ environment. Leaves point at the end of the line."
hoffset
vspace)
)))
-;;;_ > allout-insert-latex-trailer (buf)
-(defun allout-insert-latex-trailer (buf)
+;;;_ > allout-insert-latex-trailer (buffer)
+(defun allout-insert-latex-trailer (buffer)
"Insert concluding latex commands at point in BUFFER."
- (set-buffer buf)
+ (set-buffer buffer)
(insert "\n\\end{document}\n"))
;;;_ > allout-latexify-one-item (depth prefix bullet text)
(defun allout-latexify-one-item (depth prefix bullet text)
@@ -4731,9 +4703,9 @@ function. If HOOK is void, it is first set to nil."
(cons function (symbol-value hook)))))))
;;;_ : my-mark-marker to accommodate divergent emacsen:
(defun my-mark-marker (&optional force buffer)
- "Accommodate the different signature for mark-marker across emacsen.
+ "Accommodate the different signature for mark-marker across Emacsen.
-GNU XEmacs takes two optional args, while mainline GNU Emacs does not,
+XEmacs takes two optional args, while GNU Emacs does not,
so pass them along when appropriate."
(if (featurep 'xemacs)
(mark-marker force buffer)
diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el
index ba00d915d73..6c20cf41165 100644
--- a/lisp/arc-mode.el
+++ b/lisp/arc-mode.el
@@ -837,6 +837,14 @@ using `make-temp-file', and the generated name is returned."
(or (and archive-subfile-mode (aref archive-subfile-mode 0))
archive)))
(make-directory archive-tmpdir t)
+ ;; If ARCHIVE includes leading directories, make sure they
+ ;; exist under archive-tmpdir.
+ (let ((arch-dir (file-name-directory archive)))
+ (if arch-dir
+ (make-directory (concat
+ (file-name-as-directory archive-tmpdir)
+ arch-dir)
+ t)))
(setq archive-local-name
(archive-unique-fname archive-name archive-tmpdir))
(save-restriction
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 489593aa925..88acbd04792 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -136,7 +136,7 @@ If this contains a %s, that will be replaced by the matching rule."
(("\\.[1-9]\\'" . "Man page skeleton")
"Short description: "
".\\\" Copyright (C), " (substring (current-time-string) -4) " "
- (getenv "ORGANIZATION") | "Free Software Foundation, Inc."
+ (getenv "ORGANIZATION") | (progn user-full-name)
"
.\\\" You may distribute this file under the terms of the GNU Free
.\\\" Documentation Licence.
diff --git a/lisp/autorevert.el b/lisp/autorevert.el
index 58bb6d29705..7b786882cf6 100644
--- a/lisp/autorevert.el
+++ b/lisp/autorevert.el
@@ -36,8 +36,12 @@
;; Auto-Revert Mode. Both modes automatically revert buffers
;; whenever the corresponding files have been changed on disk.
;;
-;; Auto-Revert Mode can be activated for individual buffers.
-;; Global Auto-Revert Mode applies to all file buffers.
+;; Auto-Revert Mode can be activated for individual buffers. Global
+;; Auto-Revert Mode applies to all file buffers. (If the user option
+;; `global-auto-revert-non-file-buffers' is non-nil, it also applies
+;; to some non-file buffers. This option is disabled by default.)
+;; Since checking a remote file is too slow, these modes do not check
+;; or revert remote files.
;;
;; Both modes operate by checking the time stamp of all files at
;; intervals of `auto-revert-interval'. The default is every five
@@ -170,20 +174,21 @@ would only waste precious space."
:type 'hook)
(defcustom global-auto-revert-non-file-buffers nil
- "When nil only file buffers are reverted by Global Auto-Revert Mode.
+ "When nil, Global Auto-Revert mode operates only on file-visiting buffers.
When non-nil, both file buffers and buffers with a custom
`revert-buffer-function' and a `buffer-stale-function' are
-reverted by Global Auto-Revert Mode.
-
-Use this option with care since it could lead to excessive reverts.
-Note also that for some non-file buffers the check whether the
-buffer needs updating may be imperfect, due to efficiency
-considerations, and may not take all information listed in the
-buffer into account. Hence, a non-nil value for this option does
-not necessarily make manual updates useless for non-file buffers."
+reverted by Global Auto-Revert mode. These include the Buffer
+List buffer, and Dired buffers showing complete local
+directories. Dired buffers do not auto-revert as a result of
+changes in subdirectories or in the contents, size, modes, etc.,
+of files. You may still sometimes want to revert them manually.
+
+Use this option with care since it could lead to excessive auto-reverts.
+For more information, see Info node `(emacs-xtra)Autorevert'."
:group 'auto-revert
- :type 'boolean)
+ :type 'boolean
+ :link '(info-link "(emacs-xtra)Autorevert"))
(defcustom global-auto-revert-ignore-modes '()
"List of major modes Global Auto-Revert Mode should not check."
@@ -311,6 +316,7 @@ This is an internal function used by Auto-Revert Mode."
(unless (buffer-modified-p)
(let ((buffer (current-buffer)) revert eob eoblist)
(or (and buffer-file-name
+ (not (file-remote-p buffer-file-name))
(file-readable-p buffer-file-name)
(not (verify-visited-file-modtime buffer))
(setq revert t))
diff --git a/lisp/battery.el b/lisp/battery.el
index c82d3ac02b3..73d78067571 100644
--- a/lisp/battery.el
+++ b/lisp/battery.el
@@ -61,7 +61,7 @@ introduced by a `%' character in a control string."
(cond ((eq battery-status-function 'battery-linux-proc-apm)
"Power %L, battery %B (%p%% load, remaining time %t)")
((eq battery-status-function 'battery-linux-proc-acpi)
- "Power %L, battery %B at %r mA (%p%% load, remaining time %t)"))
+ "Power %L, battery %B at %r (%p%% load, remaining time %t)"))
"*Control string formatting the string to display in the echo area.
Ordinary characters in the control string are printed as-is, while
conversion specifications introduced by a `%' character in the control
@@ -243,7 +243,8 @@ The following %-sequences are provided:
%m Remaining time in minutes
%h Remaining time in hours
%t Remaining time in the form `h:min'"
- (let (capacity design-capacity rate charging-state warn low minutes hours)
+ (let (capacity design-capacity rate rate-type charging-state warn low
+ minutes hours)
(when (file-directory-p "/proc/acpi/battery/")
;; ACPI provides information about each battery present in the system in
;; a separate subdirectory. We are going to merge the available
@@ -261,32 +262,41 @@ The following %-sequences are provided:
;; battery is "charging"/"discharging", the others are
;; "unknown".
(setq charging-state (match-string 1)))
- (when (re-search-forward "present rate: +\\([0-9]+\\) mA$" nil t)
- (setq rate (+ (or rate 0) (string-to-int (match-string 1)))))
- (when (re-search-forward "remaining capacity: +\\([0-9]+\\) mAh$"
+ (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$"
+ nil t)
+ (setq rate (+ (or rate 0) (string-to-int (match-string 1)))
+ rate-type (or (and rate-type
+ (if (string= rate-type (match-string 2))
+ rate-type
+ (error
+ "Inconsistent rate types (%s vs. %s)"
+ rate-type (match-string 2))))
+ (match-string 2))))
+ (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$"
nil t)
(setq capacity
(+ (or capacity 0) (string-to-int (match-string 1))))))
(goto-char (point-max))
(insert-file-contents (expand-file-name "info" dir))
(when (re-search-forward "present: +yes$" nil t)
- (when (re-search-forward "design capacity: +\\([0-9]+\\) mAh$"
+ (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$"
nil t)
(setq design-capacity (+ (or design-capacity 0)
(string-to-int (match-string 1)))))
- (when (re-search-forward "design capacity warning: +\\([0-9]+\\) mAh$"
+ (when (re-search-forward "design capacity warning: +\\([0-9]+\\) m[AW]h$"
nil t)
(setq warn (+ (or warn 0) (string-to-int (match-string 1)))))
- (when (re-search-forward "design capacity low: +\\([0-9]+\\) mAh$"
+ (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$"
nil t)
(setq low (+ (or low 0)
(string-to-int (match-string 1))))))))
(directory-files "/proc/acpi/battery/" t "BAT")))
(and capacity rate
- (setq minutes (floor (* (/ (float (if (string= charging-state
- "charging")
- (- design-capacity capacity)
- capacity)) rate) 60))
+ (setq minutes (if (zerop rate) 0
+ (floor (* (/ (float (if (string= charging-state
+ "charging")
+ (- design-capacity capacity)
+ capacity)) rate) 60)))
hours (/ minutes 60)))
(list (cons ?c (or (and capacity (number-to-string capacity)) "N/A"))
(cons ?L (or (when (file-exists-p "/proc/acpi/ac_adapter/AC/state")
@@ -304,8 +314,17 @@ The following %-sequences are provided:
(when (re-search-forward
"temperature: +\\([0-9]+\\) C$" nil t)
(match-string 1))))
+ (when (file-exists-p
+ "/proc/acpi/thermal_zone/THM/temperature")
+ (with-temp-buffer
+ (insert-file-contents
+ "/proc/acpi/thermal_zone/THM/temperature")
+ (when (re-search-forward
+ "temperature: +\\([0-9]+\\) C$" nil t)
+ (match-string 1))))
"N/A"))
- (cons ?r (or (and rate (number-to-string rate)) "N/A"))
+ (cons ?r (or (and rate (concat (number-to-string rate) " "
+ rate-type)) "N/A"))
(cons ?B (or charging-state "N/A"))
(cons ?b (or (and (string= charging-state "charging") "+")
(and low (< capacity low) "!")
diff --git a/lisp/bindings.el b/lisp/bindings.el
index a20b45bfe81..caf857c63e7 100644
--- a/lisp/bindings.el
+++ b/lisp/bindings.el
@@ -460,7 +460,7 @@ Menu of mode operations in the mode line.")
FMT is a format specifier such as \"%12b\". This function adds
text properties for face, help-echo, and local-map to it."
(list (propertize fmt
- 'face '(:weight bold)
+ 'face 'Buffer-menu-buffer-face
'help-echo
(purecopy "mouse-1: previous buffer, mouse-3: next buffer")
'local-map mode-line-buffer-identification-keymap)))
@@ -524,7 +524,9 @@ is okay. See `mode-line-format'.")
;; files you do want to see, not just TeX stuff. -- fx
".toc" ".aux"
".cp" ".fn" ".ky" ".pg" ".tp" ".vr"
- ".cps" ".fns" ".kys" ".pgs" ".tps" ".vrs")))
+ ".cps" ".fns" ".kys" ".pgs" ".tps" ".vrs"
+ ;; Python byte-compiled
+ ".pyc" ".pyo")))
;; Suffixes used for executables.
(setq exec-suffixes
@@ -542,63 +544,20 @@ is okay. See `mode-line-format'.")
file-supersession
"^Previous command was not a yank$"
"^Minibuffer window is not active$"
+ "^No previous history search regexp$"
+ "^No later matching history item$"
+ "^No earlier matching history item$"
+ "^End of history; no default available$"
"^End of history; no next item$"
"^Beginning of history; no preceding item$"
"^No recursive edit is in progress$"
"^Changes to be undone are outside visible portion of buffer$"
"^No undo information in this buffer$"
- "^No further undo information$"
+ "^No further undo information"
"^Save not confirmed$"
"^Recover-file cancelled\\.$"
"^Cannot switch buffers in a dedicated window$"
-
- ;; ediff
- "^Errors in diff output. Diff output is in "
- "^Hmm... I don't see an Ediff command around here...$"
- "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$"
- ": This command runs in Ediff Control Buffer only!$"
- ": Invalid op in ediff-check-version$"
- "^ediff-shrink-window-C can be used only for merging jobs$"
- "^Lost difference info on these directories$"
- "^This command is inapplicable in the present context$"
- "^This session group has no parent$"
- "^Can't hide active session, $"
- "^Ediff: something wrong--no multiple diffs buffer$"
- "^Can't make context diff for Session $"
- "^The patch buffer wasn't found$"
- "^Aborted$"
- "^This Ediff session is not part of a session group$"
- "^No active Ediff sessions or corrupted session registry$"
- "^No session info in this line$"
- "^`.*' is not an ordinary file$"
- "^Patch appears to have failed$"
- "^Recomputation of differences cancelled$"
- "^No fine differences in this mode$"
- "^Lost connection to ancestor buffer...sorry$"
- "^Not merging with ancestor$"
- "^Don't know how to toggle read-only in buffer "
- "Emacs is not running as a window application$"
- "^This command makes sense only when merging with an ancestor$"
- "^At end of the difference list$"
- "^At beginning of the difference list$"
- "^Nothing saved for diff .* in buffer "
- "^Buffer is out of sync for file "
- "^Buffer out of sync for file "
- "^Output from `diff' not found$"
- "^You forgot to specify a region in buffer "
- "^All right. Make up your mind and come back...$"
- "^Current buffer is not visiting any file$"
- "^Failed to retrieve revision: $"
- "^Can't determine display width.$"
- "^File `.*' does not exist or is not readable$"
- "^File `.*' is a directory$"
- "^Buffer .* doesn't exist$"
- "^Directories . and . are the same: "
- "^Directory merge aborted$"
- "^Merge of directory revisions aborted$"
- "^Buffer .* doesn't exist$"
- "^There is no file to merge$"
- "^Version control package .*.el not found. Use vc.el instead$"))
+ ))
(make-variable-buffer-local 'indent-tabs-mode)
@@ -939,6 +898,13 @@ language you are using."
;; This is "move to the clipboard", or as close as we come.
(global-set-key [S-delete] 'kill-region)
+(global-set-key [C-M-left] 'backward-sexp)
+(global-set-key [C-M-right] 'forward-sexp)
+(global-set-key [C-M-up] 'backward-up-list)
+(global-set-key [C-M-down] 'down-list)
+(global-set-key [C-M-home] 'beginning-of-defun)
+(global-set-key [C-M-end] 'end-of-defun)
+
(define-key esc-map "\C-f" 'forward-sexp)
(define-key esc-map "\C-b" 'backward-sexp)
(define-key esc-map "\C-u" 'backward-up-list)
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 67ae2c84865..b25c261c1e7 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -376,7 +376,11 @@ That is, all information but the name."
(if cell
(setcdr cell filename)
(nconc (bookmark-get-bookmark-record bookmark)
- (list (cons 'filename filename))))))
+ (list (cons 'filename filename))))
+ (setq bookmark-alist-modification-count
+ (1+ bookmark-alist-modification-count))
+ (if (bookmark-time-to-save-p)
+ (bookmark-save))))
(defun bookmark-get-position (bookmark)
@@ -893,7 +897,8 @@ When you have finished composing, type \\[bookmark-send-annotation].
(make-local-variable 'bookmark-annotation-name)
(setq bookmark-annotation-name bookmark)
(use-local-map bookmark-edit-annotation-mode-map)
- (setq major-mode 'bookmark-edit-annotation-mode)
+ (setq major-mode 'bookmark-edit-annotation-mode
+ mode-name "Edit Bookmark Annotation")
(insert (funcall bookmark-read-annotation-text-func bookmark))
(let ((annotation (bookmark-get-annotation bookmark)))
(if (and annotation (not (string-equal annotation "")))
@@ -902,7 +907,8 @@ When you have finished composing, type \\[bookmark-send-annotation].
(defun bookmark-send-edited-annotation ()
- "Use buffer contents (minus beginning with `#' as annotation for a bookmark."
+ "Use buffer contents as annotation for a bookmark.
+Lines beginning with `#' are ignored."
(interactive)
(if (not (eq major-mode 'bookmark-edit-annotation-mode))
(error "Not in bookmark-edit-annotation-mode"))
@@ -1489,6 +1495,7 @@ method buffers use to resolve name collisions."
(define-key bookmark-bmenu-mode-map "m" 'bookmark-bmenu-mark)
(define-key bookmark-bmenu-mode-map "l" 'bookmark-bmenu-load)
(define-key bookmark-bmenu-mode-map "r" 'bookmark-bmenu-rename)
+ (define-key bookmark-bmenu-mode-map "R" 'bookmark-bmenu-relocate)
(define-key bookmark-bmenu-mode-map "t" 'bookmark-bmenu-toggle-filenames)
(define-key bookmark-bmenu-mode-map "a" 'bookmark-bmenu-show-annotation)
(define-key bookmark-bmenu-mode-map "A" 'bookmark-bmenu-show-all-annotations)
@@ -1587,6 +1594,7 @@ Bookmark names preceded by a \"*\" have annotations.
so the bookmark menu bookmark remains visible in its window.
\\[bookmark-bmenu-switch-other-window] -- switch the other window to this bookmark.
\\[bookmark-bmenu-rename] -- rename this bookmark \(prompts for new name\).
+\\[bookmark-bmenu-relocate] -- relocate this bookmark's file \(prompts for new file\).
\\[bookmark-bmenu-delete] -- mark this bookmark to be deleted, and move down.
\\[bookmark-bmenu-delete-backwards] -- mark this bookmark to be deleted, and move up.
\\[bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[bookmark-bmenu-delete]'.
@@ -2039,6 +2047,15 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\
(let ((bmrk (bookmark-bmenu-bookmark)))
(message (bookmark-location bmrk)))))
+(defun bookmark-bmenu-relocate ()
+ "Change the file path of the bookmark on the current line,
+ prompting with completion for the new path."
+ (interactive)
+ (if (bookmark-bmenu-check-position)
+ (let ((bmrk (bookmark-bmenu-bookmark))
+ (thispoint (point)))
+ (bookmark-relocate bmrk)
+ (goto-char thispoint))))
;;; Menu bar stuff. Prefix is "bookmark-menu".
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
index 002aec878ca..0c911ca8b7d 100644
--- a/lisp/calendar/appt.el
+++ b/lisp/calendar/appt.el
@@ -449,11 +449,10 @@ NEW-TIME is a string giving the date."
(same-window-p (buffer-name appt-disp-buf)))
;; By default, split the bottom window and use the lower part.
(appt-select-lowest-window)
- (split-window))
- (pop-to-buffer appt-disp-buf))
- (setq mode-line-format
- (concat "-------------------- Appointment in "
- min-to-app " minutes. " new-time " %-"))
+ (select-window (split-window)))
+ (switch-to-buffer appt-disp-buf))
+ (calendar-set-mode-line
+ (format " Appointment in %s minutes. %s " min-to-app new-time))
(erase-buffer)
(insert appt-msg)
(shrink-window-if-larger-than-buffer (get-buffer-window appt-disp-buf t))
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
new file mode 100644
index 00000000000..4dfd8eb16e5
--- /dev/null
+++ b/lisp/calendar/cal-bahai.el
@@ -0,0 +1,507 @@
+;;; cal-bahai.el --- calendar functions for the Baha'i calendar.
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Author: John Wiegley <johnw@gnu.org>
+;; Keywords: calendar
+;; Human-Keywords: Baha'i calendar, Baha'i, Bahai, calendar, diary
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This collection of functions implements the features of calendar.el
+;; and diary.el that deal with the Baha'i calendar.
+
+;; The Baha'i (http://www.bahai.org) calendar system is based on a
+;; solar cycle of 19 months with 19 days each. The four remaining
+;; "intercalary" days are called the Ayyam-i-Ha (days of Ha), and are
+;; placed between the 18th and 19th months. They are meant as a time
+;; of festivals preceding the 19th month, which is the month of
+;; fasting. In Gregorian leap years, there are 5 of these days (Ha
+;; has the numerical value of 5 in the arabic abjad, or
+;; letter-to-number, reckoning).
+
+;; Each month is named after an attribute of God, as are the 19 days
+;; -- which have the same names as the months. There is also a name
+;; for each year in every 19 year cycle. These cycles are called
+;; Vahids. A cycle of 19 Vahids (361 years) is called a Kullu-Shay,
+;; which means "all things".
+
+;; The calendar was named the "Badi calendar" by its author, the Bab.
+;; It uses a week of seven days, corresponding to the Gregorian week,
+;; each of which has its own name, again patterned after the
+;; attributes of God.
+
+;; Note: The days of Ayyam-i-Ha are encoded as zero and negative
+;; offsets from the first day of the final month. So, (19 -3 157) is
+;; the first day of Ayyam-i-Ha, in the year 157 BE.
+
+;;; Code:
+
+(require 'cal-julian)
+
+(defvar bahai-calendar-month-name-array
+ ["Baha" "Jalal" "Jamal" "`Azamat" "Nur" "Rahmat" "Kalimat" "Kamal"
+ "Asma" "`Izzat" "Mashiyyat" "`Ilm" "Qudrat" "Qawl" "Masa'il"
+ "Sharaf" "Sultan" "Mulk" "`Ala"])
+
+(defvar calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844))
+ "Absolute date of start of Baha'i calendar = March 19, 622 A.D. (Julian).")
+
+(defun bahai-calendar-leap-year-p (year)
+ "True if YEAR is a leap year on the Baha'i calendar."
+ (calendar-leap-year-p (+ year 1844)))
+
+(defvar bahai-calendar-leap-base
+ (+ (/ 1844 4) (- (/ 1844 100)) (/ 1844 400)))
+
+(defun calendar-absolute-from-bahai (date)
+ "Compute absolute date from Baha'i date DATE.
+The absolute date is the number of days elapsed since the (imaginary)
+Gregorian date Sunday, December 31, 1 BC."
+ (let* ((month (extract-calendar-month date))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (prior-years (+ (1- year) 1844))
+ (leap-days (- (+ (/ prior-years 4) ; Leap days in prior years.
+ (- (/ prior-years 100))
+ (/ prior-years 400))
+ bahai-calendar-leap-base)))
+ (+ (1- calendar-bahai-epoch) ; Days before epoch
+ (* 365 (1- year)) ; Days in prior years.
+ leap-days
+ (calendar-sum m 1 (< m month) 19)
+ (if (= month 19) 4 0)
+ day))) ; Days so far this month.
+
+(defun calendar-bahai-from-absolute (date)
+ "Baha'i year corresponding to the absolute DATE."
+ (if (< date calendar-bahai-epoch)
+ (list 0 0 0) ;; pre-Baha'i date
+ (let* ((greg (calendar-gregorian-from-absolute date))
+ (year (+ (- (extract-calendar-year greg) 1844)
+ (if (or (> (extract-calendar-month greg) 3)
+ (and (= (extract-calendar-month greg) 3)
+ (>= (extract-calendar-day greg) 21)))
+ 1 0)))
+ (month ;; Search forward from Baha.
+ (1+ (calendar-sum m 1
+ (> date
+ (calendar-absolute-from-bahai
+ (list m 19 year)))
+ 1)))
+ (day ;; Calculate the day by subtraction.
+ (- date
+ (1- (calendar-absolute-from-bahai (list month 1 year))))))
+ (list month day year))))
+
+(defun calendar-bahai-date-string (&optional date)
+ "String of Baha'i date of Gregorian DATE.
+Defaults to today's date if DATE is not given."
+ (let* ((bahai-date (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (or date (calendar-current-date)))))
+ (y (extract-calendar-year bahai-date))
+ (m (extract-calendar-month bahai-date))
+ (d (extract-calendar-day bahai-date)))
+ (let ((monthname
+ (if (and (= m 19)
+ (<= d 0))
+ "Ayyam-i-Ha"
+ (aref bahai-calendar-month-name-array (1- m))))
+ (day (int-to-string
+ (if (<= d 0)
+ (if (bahai-calendar-leap-year-p y)
+ (+ d 5)
+ (+ d 4))
+ d)))
+ (dayname nil)
+ (month (int-to-string m))
+ (year (int-to-string y)))
+ (mapconcat 'eval calendar-date-display-form ""))))
+
+(defun calendar-print-bahai-date ()
+ "Show the Baha'i calendar equivalent of the selected date."
+ (interactive)
+ (message "Baha'i date: %s"
+ (calendar-bahai-date-string (calendar-cursor-to-date t))))
+
+(defun calendar-goto-bahai-date (date &optional noecho)
+ "Move cursor to Baha'i date DATE.
+Echo Baha'i date unless NOECHO is t."
+ (interactive (bahai-prompt-for-date))
+ (calendar-goto-date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-bahai date)))
+ (or noecho (calendar-print-bahai-date)))
+
+(defun bahai-prompt-for-date ()
+ "Ask for a Baha'i date."
+ (let* ((today (calendar-current-date))
+ (year (calendar-read
+ "Baha'i calendar year (not 0): "
+ '(lambda (x) (/= x 0))
+ (int-to-string
+ (extract-calendar-year
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian today))))))
+ (completion-ignore-case t)
+ (month (cdr (assoc
+ (completing-read
+ "Baha'i calendar month name: "
+ (mapcar 'list
+ (append bahai-calendar-month-name-array nil))
+ nil t)
+ (calendar-make-alist bahai-calendar-month-name-array
+ 1))))
+ (day (calendar-read "Baha'i calendar day (1-19): "
+ '(lambda (x) (and (< 0 x) (<= x 19))))))
+ (list (list month day year))))
+
+(defun diary-bahai-date ()
+ "Baha'i calendar equivalent of date diary entry."
+ (format "Baha'i date: %s" (calendar-bahai-date-string date)))
+
+(defun holiday-bahai (month day string)
+ "Holiday on MONTH, DAY (Baha'i) called STRING.
+If MONTH, DAY (Baha'i) is visible, the value returned is corresponding
+Gregorian date in the form of the list (((month day year) STRING)). Returns
+nil if it is not visible in the current calendar window."
+ (let* ((bahai-date (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (list displayed-month 15 displayed-year))))
+ (m (extract-calendar-month bahai-date))
+ (y (extract-calendar-year bahai-date))
+ (date))
+ (if (< m 1)
+ nil ;; Baha'i calendar doesn't apply.
+ (increment-calendar-month m y (- 10 month))
+ (if (> m 7) ;; Baha'i date might be visible
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-bahai (list month day y)))))
+ (if (calendar-date-is-visible-p date)
+ (list (list date string))))))))
+
+(defun list-bahai-diary-entries ()
+ "Add any Baha'i date entries from the diary file to `diary-entries-list'.
+Baha'i date diary entries must be prefaced by an
+`bahai-diary-entry-symbol' (normally a `B'). The same diary date
+forms govern the style of the Baha'i calendar entries, except that the
+Baha'i month names must be given numerically. The Baha'i months are
+numbered from 1 to 19 with Baha being 1 and 19 being `Ala. If a
+Baha'i date diary entry begins with a `diary-nonmarking-symbol', the
+entry will appear in the diary listing, but will not be marked in the
+calendar. This function is provided for use with the
+`nongregorian-diary-listing-hook'."
+ (if (< 0 number)
+ (let ((buffer-read-only nil)
+ (diary-modified (buffer-modified-p))
+ (gdate original-date)
+ (mark (regexp-quote diary-nonmarking-symbol)))
+ (calendar-for-loop i from 1 to number do
+ (let* ((d diary-date-forms)
+ (bdate (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian gdate)))
+ (month (extract-calendar-month bdate))
+ (day (extract-calendar-day bdate))
+ (year (extract-calendar-year bdate)))
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)))
+ (backup (equal (car (car d)) 'backup))
+ (dayname
+ (concat
+ (calendar-day-name gdate) "\\|"
+ (substring (calendar-day-name gdate) 0 3) ".?"))
+ (calendar-month-name-array
+ bahai-calendar-month-name-array)
+ (monthname
+ (concat
+ "\\*\\|"
+ (calendar-month-name month)))
+ (month (concat "\\*\\|0*" (int-to-string month)))
+ (day (concat "\\*\\|0*" (int-to-string day)))
+ (year
+ (concat
+ "\\*\\|0*" (int-to-string year)
+ (if abbreviated-calendar-year
+ (concat "\\|" (int-to-string (% year 100)))
+ "")))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)" mark "?"
+ (regexp-quote bahai-diary-entry-symbol)
+ "\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (if backup (re-search-backward "\\<" nil t))
+ (if (and (or (char-equal (preceding-char) ?\^M)
+ (char-equal (preceding-char) ?\n))
+ (not (looking-at " \\|\^I")))
+ ;; Diary entry that consists only of date.
+ (backward-char 1)
+ ;; Found a nonempty diary entry--make it visible and
+ ;; add it to the list.
+ (let ((entry-start (point))
+ (date-start))
+ (re-search-backward "\^M\\|\n\\|\\`")
+ (setq date-start (point))
+ (re-search-forward "\^M\\|\n" nil t 2)
+ (while (looking-at " \\|\^I")
+ (re-search-forward "\^M\\|\n" nil t))
+ (backward-char 1)
+ (subst-char-in-region date-start (point) ?\^M ?\n t)
+ (add-to-diary-list
+ gdate
+ (buffer-substring-no-properties entry-start (point))
+ (buffer-substring-no-properties
+ (1+ date-start) (1- entry-start)))))))
+ (setq d (cdr d))))
+ (setq gdate
+ (calendar-gregorian-from-absolute
+ (1+ (calendar-absolute-from-gregorian gdate)))))
+ (set-buffer-modified-p diary-modified))
+ (goto-char (point-min))))
+
+(defun mark-bahai-diary-entries ()
+ "Mark days in the calendar window that have Baha'i date diary entries.
+Each entry in diary-file (or included files) visible in the calendar
+window is marked. Baha'i date entries are prefaced by a
+bahai-diary-entry-symbol \(normally a B`I'). The same
+diary-date-forms govern the style of the Baha'i calendar entries,
+except that the Baha'i month names must be spelled in full. The
+Baha'i months are numbered from 1 to 12 with Baha being 1 and 12 being
+`Ala. Baha'i date diary entries that begin with a
+diary-nonmarking-symbol will not be marked in the calendar. This
+function is provided for use as part of the
+nongregorian-diary-marking-hook."
+ (let ((d diary-date-forms))
+ (while d
+ (let*
+ ((date-form (if (equal (car (car d)) 'backup)
+ (cdr (car d))
+ (car d)));; ignore 'backup directive
+ (dayname (diary-name-pattern calendar-day-name-array))
+ (monthname
+ (concat
+ (diary-name-pattern bahai-calendar-month-name-array t)
+ "\\|\\*"))
+ (month "[0-9]+\\|\\*")
+ (day "[0-9]+\\|\\*")
+ (year "[0-9]+\\|\\*")
+ (l (length date-form))
+ (d-name-pos (- l (length (memq 'dayname date-form))))
+ (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
+ (m-name-pos (- l (length (memq 'monthname date-form))))
+ (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
+ (d-pos (- l (length (memq 'day date-form))))
+ (d-pos (if (/= l d-pos) (+ 2 d-pos)))
+ (m-pos (- l (length (memq 'month date-form))))
+ (m-pos (if (/= l m-pos) (+ 2 m-pos)))
+ (y-pos (- l (length (memq 'year date-form))))
+ (y-pos (if (/= l y-pos) (+ 2 y-pos)))
+ (regexp
+ (concat
+ "\\(\\`\\|\^M\\|\n\\)"
+ (regexp-quote bahai-diary-entry-symbol)
+ "\\("
+ (mapconcat 'eval date-form "\\)\\(")
+ "\\)"))
+ (case-fold-search t))
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (let* ((dd-name
+ (if d-name-pos
+ (buffer-substring
+ (match-beginning d-name-pos)
+ (match-end d-name-pos))))
+ (mm-name
+ (if m-name-pos
+ (buffer-substring
+ (match-beginning m-name-pos)
+ (match-end m-name-pos))))
+ (mm (string-to-int
+ (if m-pos
+ (buffer-substring
+ (match-beginning m-pos)
+ (match-end m-pos))
+ "")))
+ (dd (string-to-int
+ (if d-pos
+ (buffer-substring
+ (match-beginning d-pos)
+ (match-end d-pos))
+ "")))
+ (y-str (if y-pos
+ (buffer-substring
+ (match-beginning y-pos)
+ (match-end y-pos))))
+ (yy (if (not y-str)
+ 0
+ (if (and (= (length y-str) 2)
+ abbreviated-calendar-year)
+ (let* ((current-y
+ (extract-calendar-year
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date)))))
+ (y (+ (string-to-int y-str)
+ (* 100 (/ current-y 100)))))
+ (if (> (- y current-y) 50)
+ (- y 100)
+ (if (> (- current-y y) 50)
+ (+ y 100)
+ y)))
+ (string-to-int y-str)))))
+ (if dd-name
+ (mark-calendar-days-named
+ (cdr (assoc-ignore-case (substring dd-name 0 3)
+ (calendar-make-alist
+ calendar-day-name-array
+ 0
+ '(lambda (x) (substring x 0 3))))))
+ (if mm-name
+ (if (string-equal mm-name "*")
+ (setq mm 0)
+ (setq mm
+ (cdr (assoc-ignore-case
+ mm-name
+ (calendar-make-alist
+ bahai-calendar-month-name-array))))))
+ (mark-bahai-calendar-date-pattern mm dd yy)))))
+ (setq d (cdr d)))))
+
+(defun mark-bahai-calendar-date-pattern (month day year)
+ "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR.
+A value of 0 in any position is a wildcard."
+ (save-excursion
+ (set-buffer calendar-buffer)
+ (if (and (/= 0 month) (/= 0 day))
+ (if (/= 0 year)
+ ;; Fully specified Baha'i date.
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-bahai
+ (list month day year)))))
+ (if (calendar-date-is-visible-p date)
+ (mark-visible-calendar-date date)))
+ ;; Month and day in any year--this taken from the holiday stuff.
+ (let* ((bahai-date (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (list displayed-month 15 displayed-year))))
+ (m (extract-calendar-month bahai-date))
+ (y (extract-calendar-year bahai-date))
+ (date))
+ (if (< m 1)
+ nil;; Baha'i calendar doesn't apply.
+ (increment-calendar-month m y (- 10 month))
+ (if (> m 7);; Baha'i date might be visible
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-bahai
+ (list month day y)))))
+ (if (calendar-date-is-visible-p date)
+ (mark-visible-calendar-date date)))))))
+ ;; Not one of the simple cases--check all visible dates for match.
+ ;; Actually, the following code takes care of ALL of the cases, but
+ ;; it's much too slow to be used for the simple (common) cases.
+ (let ((m displayed-month)
+ (y displayed-year)
+ (first-date)
+ (last-date))
+ (increment-calendar-month m y -1)
+ (setq first-date
+ (calendar-absolute-from-gregorian
+ (list m 1 y)))
+ (increment-calendar-month m y 2)
+ (setq last-date
+ (calendar-absolute-from-gregorian
+ (list m (calendar-last-day-of-month m y) y)))
+ (calendar-for-loop date from first-date to last-date do
+ (let* ((b-date (calendar-bahai-from-absolute date))
+ (i-month (extract-calendar-month b-date))
+ (i-day (extract-calendar-day b-date))
+ (i-year (extract-calendar-year b-date)))
+ (and (or (zerop month)
+ (= month i-month))
+ (or (zerop day)
+ (= day i-day))
+ (or (zerop year)
+ (= year i-year))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date)))))))))
+
+(defun insert-bahai-diary-entry (arg)
+ "Insert a diary entry.
+For the Baha'i date corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-month-name-array bahai-calendar-month-name-array))
+ (make-diary-entry
+ (concat
+ bahai-diary-entry-symbol
+ (calendar-date-string
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))
+ nil t))
+ arg)))
+
+(defun insert-monthly-bahai-diary-entry (arg)
+ "Insert a monthly diary entry.
+For the day of the Baha'i month corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style '(day " * ") '("* " day )))
+ (calendar-month-name-array bahai-calendar-month-name-array))
+ (make-diary-entry
+ (concat
+ bahai-diary-entry-symbol
+ (calendar-date-string
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))))
+ arg)))
+
+(defun insert-yearly-bahai-diary-entry (arg)
+ "Insert an annual diary entry.
+For the day of the Baha'i year corresponding to the date indicated by point.
+Prefix arg will make the entry nonmarking."
+ (interactive "P")
+ (let* ((calendar-date-display-form
+ (if european-calendar-style
+ '(day " " monthname)
+ '(monthname " " day)))
+ (calendar-month-name-array bahai-calendar-month-name-array))
+ (make-diary-entry
+ (concat
+ bahai-diary-entry-symbol
+ (calendar-date-string
+ (calendar-bahai-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-cursor-to-date t)))))
+ arg)))
+
+(provide 'cal-bahai)
+
+;;; arch-tag: c1cb1d67-862a-4264-a01c-41cb4df01f14
+;;; cal-bahai.el ends here
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index 3c6cc78eb7b..a652e7ca768 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -66,6 +66,8 @@
'("Insert Hebrew" . calendar-mouse-insert-hebrew-diary-entry))
(define-key calendar-mode-map [menu-bar diary isl]
'("Insert Islamic" . calendar-mouse-insert-islamic-diary-entry))
+(define-key calendar-mode-map [menu-bar diary baha]
+ '("Insert Baha'i" . calendar-mouse-insert-bahai-diary-entry))
(define-key calendar-mode-map [menu-bar diary cyc]
'("Insert Cyclic" . insert-cyclic-diary-entry))
(define-key calendar-mode-map [menu-bar diary blk]
@@ -110,6 +112,8 @@
(define-key calendar-mode-map [menu-bar goto islamic]
'("Islamic Date" . calendar-goto-islamic-date))
(define-key calendar-mode-map [menu-bar goto persian]
+ '("Baha'i Date" . calendar-goto-bahai-date))
+(define-key calendar-mode-map [menu-bar goto persian]
'("Persian Date" . calendar-goto-persian-date))
(define-key calendar-mode-map [menu-bar goto hebrew]
'("Hebrew Date" . calendar-goto-hebrew-date))
@@ -288,6 +292,19 @@ ERROR is t, otherwise just returns nil."
'("Yearly" . insert-yearly-islamic-diary-entry))))))
(and islamic-selection (call-interactively islamic-selection))))
+(defun calendar-mouse-insert-bahai-diary-entry (event)
+ "Pop up menu to insert an Baha'i-date diary entry."
+ (interactive "e")
+ (let ((bahai-selection
+ (x-popup-menu
+ event
+ (list "Baha'i insert menu"
+ (list (calendar-bahai-date-string (calendar-cursor-to-date))
+ '("One time" . insert-bahai-diary-entry)
+ '("Monthly" . insert-monthly-bahai-diary-entry)
+ '("Yearly" . insert-yearly-bahai-diary-entry))))))
+ (and bahai-selection (call-interactively bahai-selection))))
+
(defun calendar-mouse-sunrise/sunset ()
"Show sunrise/sunset times for mouse-selected date."
(interactive)
@@ -496,7 +513,9 @@ The output is in landscape format, one month to a page."
(list (format "Hebrew date (before sunset): %s"
(calendar-hebrew-date-string date)))
(list (format "Persian date: %s"
- (calendar-persian-date-string date))))
+ (calendar-persian-date-string date)))
+ (list (format "Baha'i date (before sunset): %s"
+ (calendar-bahai-date-string date))))
(let ((i (calendar-islamic-date-string date)))
(if (not (string-equal i ""))
(list (list (format "Islamic date (before sunset): %s" i)))))
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 0d38563e637..43171255bbe 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -26,26 +26,29 @@
;;; Commentary:
-;; This collection of functions implements a calendar window. It generates a
-;; calendar for the current month, together with the previous and coming
-;; months, or for any other three-month period. The calendar can be scrolled
-;; forward and backward in the window to show months in the past or future;
-;; the cursor can move forward and backward by days, weeks, or months, making
-;; it possible, for instance, to jump to the date a specified number of days,
-;; weeks, or months from the date under the cursor. The user can display a
-;; list of holidays and other notable days for the period shown; the notable
-;; days can be marked on the calendar, if desired. The user can also specify
-;; that dates having corresponding diary entries (in a file that the user
-;; specifies) be marked; the diary entries for any date can be viewed in a
-;; separate window. The diary and the notable days can be viewed
-;; independently of the calendar. Dates can be translated from the (usual)
-;; Gregorian calendar to the day of the year/days remaining in year, to the
-;; ISO commercial calendar, to the Julian (old style) calendar, to the Hebrew
-;; calendar, to the Islamic calendar, to the French Revolutionary calendar, to
-;; the Mayan calendar, to the Chinese calendar, to the Coptic calendar, to the
-;; Ethiopic calendar, and to the astronomical (Julian) day number. When
-;; floating point is available, times of sunrise/sunset can be displayed, as
-;; can the phases of the moon. Appointment notification for diary entries is
+;; This collection of functions implements a calendar window. It
+;; generates a calendar for the current month, together with the
+;; previous and coming months, or for any other three-month period.
+;; The calendar can be scrolled forward and backward in the window to
+;; show months in the past or future; the cursor can move forward and
+;; backward by days, weeks, or months, making it possible, for
+;; instance, to jump to the date a specified number of days, weeks, or
+;; months from the date under the cursor. The user can display a list
+;; of holidays and other notable days for the period shown; the
+;; notable days can be marked on the calendar, if desired. The user
+;; can also specify that dates having corresponding diary entries (in
+;; a file that the user specifies) be marked; the diary entries for
+;; any date can be viewed in a separate window. The diary and the
+;; notable days can be viewed independently of the calendar. Dates
+;; can be translated from the (usual) Gregorian calendar to the day of
+;; the year/days remaining in year, to the ISO commercial calendar, to
+;; the Julian (old style) calendar, to the Hebrew calendar, to the
+;; Islamic calendar, to the Baha'i calendar, to the French
+;; Revolutionary calendar, to the Mayan calendar, to the Chinese
+;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to
+;; the astronomical (Julian) day number. When floating point is
+;; available, times of sunrise/sunset can be displayed, as can the
+;; phases of the moon. Appointment notification for diary entries is
;; available. Calendar printing via LaTeX is available.
;; The following files are part of the calendar/diary code:
@@ -56,6 +59,7 @@
;; cal-dst.el Daylight savings time rules
;; cal-hebrew.el Hebrew calendar
;; cal-islam.el Islamic calendar
+;; cal-bahai.el Baha'i calendar
;; cal-iso.el ISO calendar
;; cal-julian.el Julian/astronomical calendars
;; cal-mayan.el Mayan calendars
@@ -317,6 +321,16 @@ calendar."
:group 'diary)
;;;###autoload
+(defcustom all-bahai-calendar-holidays nil
+ "*If nil, show only major holidays from the Baha'i calendar.
+These are the days on which work and school must be suspended.
+
+If t, show all the holidays that would appear in a complete Baha'i
+calendar."
+ :type 'boolean
+ :group 'holidays)
+
+;;;###autoload
(defcustom calendar-load-hook nil
"*List of functions to be called after the calendar is first loaded.
This is the place to add key bindings to `calendar-mode-map'."
@@ -463,21 +477,23 @@ Diary entries can be based on Lisp sexps. For example, the diary entry
%%(diary-block 11 1 1990 11 10 1990) Vacation
-causes the diary entry \"Vacation\" to appear from November 1 through November
-10, 1990. Other functions available are `diary-float', `diary-anniversary',
-`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date',
-`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date',
+causes the diary entry \"Vacation\" to appear from November 1 through
+November 10, 1990. Other functions available are `diary-float',
+`diary-anniversary', `diary-cyclic', `diary-day-of-year',
+`diary-iso-date', `diary-french-date', `diary-hebrew-date',
+`diary-islamic-date', `diary-bahai-date', `diary-mayan-date',
`diary-chinese-date', `diary-coptic-date', `diary-ethiopic-date',
`diary-persian-date', `diary-yahrzeit', `diary-sunrise-sunset',
-`diary-phases-of-moon', `diary-parasha', `diary-omer', `diary-rosh-hodesh',
-and `diary-sabbath-candles'. See the documentation for the function
-`list-sexp-diary-entries' for more details.
+`diary-phases-of-moon', `diary-parasha', `diary-omer',
+`diary-rosh-hodesh', and `diary-sabbath-candles'. See the
+documentation for the function `list-sexp-diary-entries' for more
+details.
-Diary entries based on the Hebrew and/or the Islamic calendar are also
-possible, but because these are somewhat slow, they are ignored
-unless you set the `nongregorian-diary-listing-hook' and the
-`nongregorian-diary-marking-hook' appropriately. See the documentation
-for these functions for details.
+Diary entries based on the Hebrew, the Islamic and/or the Baha'i
+calendar are also possible, but because these are somewhat slow, they
+are ignored unless you set the `nongregorian-diary-listing-hook' and
+the `nongregorian-diary-marking-hook' appropriately. See the
+documentation for these functions for details.
Diary files can contain directives to include the contents of other files; for
details, see the documentation for the variable `list-diary-entries-hook'."
@@ -503,6 +519,12 @@ details, see the documentation for the variable `list-diary-entries-hook'."
:group 'diary)
;;;###autoload
+(defcustom bahai-diary-entry-symbol "B"
+ "*Symbol indicating a diary entry according to the Baha'i calendar."
+ :type 'string
+ :group 'diary)
+
+;;;###autoload
(defcustom diary-include-string "#include"
"*The string indicating inclusion of another file of diary entries.
See the documentation for the function `include-other-diary-files'."
@@ -554,8 +576,9 @@ See the documentation for the function `list-sexp-diary-entries'."
;;;###autoload
(defcustom abbreviated-calendar-year t
"*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD.
-For the Gregorian calendar; similarly for the Hebrew and Islamic calendars.
-If this variable is nil, years must be written in full."
+For the Gregorian calendar; similarly for the Hebrew, Islamic and
+Baha'i calendars. If this variable is nil, years must be written in
+full."
:type 'boolean
:group 'diary)
@@ -796,12 +819,15 @@ diary buffer, set the variable `diary-list-include-blanks' to t."
;;;###autoload
(defcustom nongregorian-diary-listing-hook nil
"*List of functions called for listing diary file and included files.
-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'
-and `list-islamic-diary-entries'. The documentation for these functions
+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
describes the style of such diary entries."
:type 'hook
- :options '(list-hebrew-diary-entries list-islamic-diary-entries)
+ :options '(list-hebrew-diary-entries
+ list-islamic-diary-entries
+ list-bahai-diary-entries)
:group 'diary)
;;;###autoload
@@ -825,12 +851,15 @@ function `include-other-diary-files' as part of `list-diary-entries-hook'."
;;;###autoload
(defcustom nongregorian-diary-marking-hook nil
"*List of functions called for marking diary file and included files.
-As the files are processed for diary entries, these functions are used to cull
-relevant entries. You can use either or both of `mark-hebrew-diary-entries'
-and `mark-islamic-diary-entries'. The documentation for these functions
+As the files are processed for diary entries, these functions are used
+to cull relevant entries. You can use either or both of
+`mark-hebrew-diary-entries', `mark-islamic-diary-entries' and
+`mark-bahai-diary-entries'. The documentation for these functions
describes the style of such diary entries."
:type 'hook
- :options '(mark-hebrew-diary-entries mark-islamic-diary-entries)
+ :options '(mark-hebrew-diary-entries
+ mark-islamic-diary-entries
+ mark-bahai-diary-entries)
:group 'diary)
;;;###autoload
@@ -1068,6 +1097,48 @@ See the documentation for `calendar-holidays' for details."
:group 'holidays)
;;;###autoload
+(put 'bahai-holidays 'risky-local-variable t)
+;;;###autoload
+(defcustom bahai-holidays
+ '((holiday-fixed
+ 3 21
+ (format "Baha'i New Year (Naw-Ruz) %d" (- displayed-year (1- 1844))))
+ (holiday-fixed 4 21 "First Day of Ridvan")
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 22 "Second Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 23 "Third Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 24 "Fourth Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 25 "Fifth Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 26 "Sixth Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 27 "Seventh Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 28 "Eighth Day of Ridvan"))
+ (holiday-fixed 4 29 "Ninth Day of Ridvan")
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 4 30 "Tenth Day of Ridvan"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 5 1 "Eleventh Day of Ridvan"))
+ (holiday-fixed 5 2 "Twelfth Day of Ridvan")
+ (holiday-fixed 5 23 "Declaration of the Bab")
+ (holiday-fixed 5 29 "Ascension of Baha'u'llah")
+ (holiday-fixed 7 9 "Martyrdom of the Bab")
+ (holiday-fixed 10 20 "Birth of the Bab")
+ (holiday-fixed 11 12 "Birth of Baha'u'llah")
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 11 26 "Day of the Covenant"))
+ (if all-bahai-calendar-holidays
+ (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha")))
+ "*Baha'i holidays.
+See the documentation for `calendar-holidays' for details."
+ :type 'sexp
+ :group 'holidays)
+
+;;;###autoload
(put 'solar-holidays 'risky-local-variable t)
;;;###autoload
(defcustom solar-holidays
@@ -1104,15 +1175,16 @@ See the documentation for `calendar-holidays' for details."
(defcustom calendar-holidays
(append general-holidays local-holidays other-holidays
christian-holidays hebrew-holidays islamic-holidays
- oriental-holidays solar-holidays)
+ bahai-holidays oriental-holidays solar-holidays)
"*List of notable days for the command \\[holidays].
-Additional holidays are easy to add to the list, just put them in the list
-`other-holidays' in your .emacs file. Similarly, by setting any of
-`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays',
-`islamic-holidays', `oriental-holidays', or `solar-holidays' to nil in your
-.emacs file, you can eliminate unwanted categories of holidays. The intention
-is that (in the US) `local-holidays' be set in site-init.el and
+Additional holidays are easy to add to the list, just put them in the
+list `other-holidays' in your .emacs file. Similarly, by setting any
+of `general-holidays', `local-holidays' `christian-holidays',
+`hebrew-holidays', `islamic-holidays', `bahai-holidays',
+`oriental-holidays', or `solar-holidays' to nil in your .emacs file,
+you can eliminate unwanted categories of holidays. The intention is
+that (in the US) `local-holidays' be set in site-init.el and
`other-holidays' be set by the user.
Entries on the list are expressions that return (possibly empty) lists of
@@ -1128,6 +1200,7 @@ Several basic functions are provided for this purpose:
DAYNAME after/before MONTH DAY.
(holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar
(holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar
+ (holiday-bahai MONTH DAY STRING) a fixed date on the Baha'i calendar
(holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar
(holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression
in the variable `year'; if it evaluates to
@@ -1155,6 +1228,11 @@ add the Islamic feast celebrating Mohammed's birthday use
(holiday-islamic 3 12 \"Mohammed's Birthday\")
since the Islamic months are numbered from 1 starting with Muharram. To
+add an entry for the Baha'i festival of Ridvan, use
+
+ (holiday-bahai 2 13 \"Festival of Ridvan\")
+
+since the Baha'i months are numbered from 1 starting with Baha. To
add Thomas Jefferson's birthday, April 2, 1743 (Julian), use
(holiday-julian 4 2 \"Jefferson's Birthday\")
@@ -1680,6 +1758,14 @@ Driven by the variable `calendar-date-display-form'.")
"String of Islamic date of Gregorian date."
t)
+(autoload 'calendar-print-bahai-date "cal-bahai"
+ "Show the Baha'i date equivalents of date."
+ t)
+
+(autoload 'calendar-bahai-date-string "cal-bahai"
+ "String of Baha'i date of Gregorian date."
+ t)
+
(autoload 'calendar-goto-hebrew-date "cal-hebrew"
"Move cursor to Hebrew date date."
t)
@@ -1803,6 +1889,21 @@ to the date indicated by point."
to the date indicated by point."
t)
+(autoload 'insert-bahai-diary-entry "cal-bahai"
+ "Insert a diary entry for the Baha'i date corresponding to the date
+indicated by point."
+ t)
+
+(autoload 'insert-monthly-bahai-diary-entry "cal-bahai"
+ "Insert a monthly diary entry for the day of the Baha'i month corresponding
+to the date indicated by point."
+ t)
+
+(autoload 'insert-yearly-bahai-diary-entry "cal-bahai"
+ "Insert an annual diary entry for the day of the Baha'i year corresponding
+to the date indicated by point."
+ t)
+
(autoload 'list-calendar-holidays "holidays"
"Create a buffer containing the holidays for the current calendar window.
The holidays are those in the list `calendar-notable-days'. Returns t if any
@@ -2066,6 +2167,7 @@ the inserted text. Value is always t."
(define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number)
(define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date)
(define-key calendar-mode-map "gi" 'calendar-goto-islamic-date)
+ (define-key calendar-mode-map "gb" 'calendar-goto-bahai-date)
(define-key calendar-mode-map "gC" 'calendar-goto-chinese-date)
(define-key calendar-mode-map "gk" 'calendar-goto-coptic-date)
(define-key calendar-mode-map "ge" 'calendar-goto-ethiopic-date)
@@ -2106,6 +2208,7 @@ the inserted text. Value is always t."
(define-key calendar-mode-map "pa" 'calendar-print-astro-day-number)
(define-key calendar-mode-map "ph" 'calendar-print-hebrew-date)
(define-key calendar-mode-map "pi" 'calendar-print-islamic-date)
+ (define-key calendar-mode-map "pb" 'calendar-print-bahai-date)
(define-key calendar-mode-map "pf" 'calendar-print-french-date)
(define-key calendar-mode-map "pm" 'calendar-print-mayan-date)
(define-key calendar-mode-map "po" 'calendar-print-other-dates)
@@ -2122,6 +2225,9 @@ the inserted text. Value is always t."
(define-key calendar-mode-map "iid" 'insert-islamic-diary-entry)
(define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry)
(define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry)
+ (define-key calendar-mode-map "iBd" 'insert-bahai-diary-entry)
+ (define-key calendar-mode-map "iBm" 'insert-monthly-bahai-diary-entry)
+ (define-key calendar-mode-map "iBy" 'insert-yearly-bahai-diary-entry)
(define-key calendar-mode-map "?" 'calendar-goto-info-node)
(define-key calendar-mode-map "tm" 'cal-tex-cursor-month)
(define-key calendar-mode-map "tM" 'cal-tex-cursor-month-landscape)
@@ -2907,6 +3013,9 @@ Defaults to today's date if DATE is not given."
(let ((i (calendar-islamic-date-string date)))
(if (not (string-equal i ""))
(format "Islamic date (before sunset): %s" i)))
+ (let ((b (calendar-bahai-date-string date)))
+ (if (not (string-equal b ""))
+ (format "Baha'i date (before sunset): %s" b)))
(format "Chinese date: %s"
(calendar-chinese-date-string date))
(let ((c (calendar-coptic-date-string date)))
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index eba932847c0..45bb3c0e4c0 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -123,6 +123,22 @@ The holidays are those in the list `calendar-holidays'.")
(autoload 'mark-islamic-calendar-date-pattern "cal-islam"
"Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.")
+(autoload 'diary-bahai-date "cal-bahai"
+ "Baha'i calendar equivalent of date diary entry."
+ t)
+
+(autoload 'list-bahai-diary-entries "cal-bahai"
+ "Add any Baha'i date entries from the diary file to `diary-entries-list'."
+ t)
+
+(autoload 'mark-bahai-diary-entries "cal-bahai"
+ "Mark days in the calendar window that have Baha'i date diary entries."
+ t)
+
+(autoload 'mark-bahai-calendar-date-pattern "cal-bahai"
+ "Mark dates in calendar window that conform to Baha'i date MONTH/DAY/YEAR."
+ t)
+
(autoload 'diary-hebrew-date "cal-hebrew"
"Hebrew calendar equivalent of date diary entry.")
@@ -1129,6 +1145,8 @@ be used instead of a colon (:) to separate the hour and minute parts."
0 1200)))
(t diary-unknown-time)))) ; Unrecognizable
+;; Unrecognizable
+
(defun list-sexp-diary-entries (date)
"Add sexp entries for DATE from the diary file to `diary-entries-list'.
Also, Make them visible in the diary file. Returns t if any entries were
@@ -1859,6 +1877,155 @@ names."
"Forms to highlight in diary-mode")
+;; Following code from Dave Love <fx@gnu.org>.
+;; Import Outlook-format appointments from mail messages in Gnus or
+;; Rmail using command `diary-from-outlook'. This, or the specialized
+;; functions `diary-from-outlook-gnus' and `diary-from-outlook-rmail',
+;; could be run from hooks to notice appointments automatically (in
+;; which case they will prompt about adding to the diary). The
+;; message formats recognized are customizable through
+;; `diary-outlook-formats'.
+
+(defcustom diary-outlook-formats
+ '(
+ ;; When: 11 October 2001 12:00-14:00 (GMT) Greenwich Mean Time : Dublin, ...
+ ;; [Current UK format? The timezone is meaningless. Sometimes the
+ ;; Where is missing.]
+ ("When: \\([0-9]+ [[:alpha:]]+ [0-9]+\\) \
+\\([^ ]+\\) [^\n]+
+\[^\n]+
+\\(?:Where: \\([^\n]+\\)\n+\\)?
+\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*~\\*"
+ . "\\1\n \\2 %s, \\3")
+ ;; When: Tuesday, April 30, 2002 03:00 PM-03:30 PM (GMT) Greenwich Mean ...
+ ;; [Old UK format?]
+ ("^When: [[:alpha:]]+, \\([[:alpha:]]+\\) \\([0-9][0-9]*\\), \\([0-9]\\{4\\}\\) \
+\\([^ ]+\\) [^\n]+
+\[^\n]+
+\\(?:Where: \\([^\n]+\\)\\)?\n+"
+ . "\\2 \\1 \\3\n \\4 %s, \\5")
+ (
+ ;; German format, apparently.
+ "^Zeit: [^ ]+, +\\([0-9]+\\)\. +\\([[:upper:]][[:lower:]][[:lower:]]\\)[^ ]* +\\([0-9]+\\) +\\([^ ]+\\).*$"
+ . "\\1 \\2 \\3\n \\4 %s"))
+ "Alist of regexps matching message text and replacement text.
+
+The regexp must match the start of the message text containing an
+appointment, but need not include a leading `^'. If it matches the
+current message, a diary entry is made from the corresponding
+template. If the template is a string, it should be suitable for
+passing to `replace-match', and so will have occurrences of `\\D' to
+substitute the match for the Dth subexpression. It must also contain
+a single `%s' which will be replaced with the text of the message's
+Subject field. Any other `%' characters must be doubled, so that the
+template can be passed to `format'.
+
+If the template is actually a function, it is called with the message
+body text as argument, and may use `match-string' etc. to make a
+template following the rules above."
+ :type '(alist :key-type (regexp :tag "Regexp matching time/place")
+ :value-type (choice
+ (string :tag "Template for entry")
+ (function :tag "Unary function providing template")))
+ :version "21.4"
+ :group 'diary)
+
+
+;; Dynamically bound.
+(defvar body)
+(defvar subject)
+
+(defun diary-from-outlook-internal (&optional test-only)
+ "Snarf a diary entry from a message assumed to be from MS Outlook.
+Assumes `body' is bound to a string comprising the body of the message and
+`subject' is bound to a string comprising its subject.
+Arg TEST-ONLY non-nil means return non-nil if and only if the
+message contains an appointment, don't make a diary entry."
+ (catch 'finished
+ (let (format-string)
+ (dotimes (i (length diary-outlook-formats))
+ (when (eq 0 (string-match (car (nth i diary-outlook-formats))
+ body))
+ (unless test-only
+ (setq format-string (cdr (nth i diary-outlook-formats)))
+ (save-excursion
+ (save-window-excursion
+ ;; Fixme: References to optional fields in the format
+ ;; are treated literally, not replaced by the empty
+ ;; string. I think this is an Emacs bug.
+ (make-diary-entry
+ (format (replace-match (if (functionp format-string)
+ (funcall format-string body)
+ format-string)
+ t nil (match-string 0 body))
+ subject))
+ (save-buffer))))
+ (throw 'finished t))))
+ nil))
+
+(defun diary-from-outlook ()
+ "Maybe snarf diary entry from current Outlook-generated message.
+Currently knows about Gnus and Rmail modes."
+ (interactive)
+ (let ((func (cond
+ ((eq major-mode 'rmail-mode)
+ #'diary-from-outlook-rmail)
+ ((memq major-mode '(gnus-summary-mode gnus-article-mode))
+ #'diary-from-outlook-gnus)
+ (t (error "Don't know how to snarf in `%s'" major-mode)))))
+ (if (interactive-p)
+ (call-interactively func)
+ (funcall func))))
+
+
+(defvar gnus-article-mime-handles)
+(defvar gnus-article-buffer)
+
+(autoload 'gnus-fetch-field "gnus-util")
+(autoload 'gnus-narrow-to-body "gnus")
+(autoload 'mm-get-part "mm-decode")
+
+(defun diary-from-outlook-gnus ()
+ "Maybe snarf diary entry from Outlook-generated message in Gnus.
+Add this to `gnus-article-prepare-hook' to notice appointments
+automatically."
+ (interactive)
+ (with-current-buffer gnus-article-buffer
+ (let ((subject (gnus-fetch-field "subject"))
+ (body (if gnus-article-mime-handles
+ ;; We're multipart. Don't get confused by part
+ ;; buttons &c. Assume info is in first part.
+ (mm-get-part (nth 1 gnus-article-mime-handles))
+ (save-restriction
+ (gnus-narrow-to-body)
+ (buffer-string)))))
+ (when (diary-from-outlook-internal t)
+ (when (or (interactive-p)
+ (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
+
+(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus)
+
+
+(defvar rmail-buffer)
+
+(defun diary-from-outlook-rmail ()
+ "Maybe snarf diary entry from Outlook-generated message in Rmail."
+ (interactive)
+ (with-current-buffer rmail-buffer
+ (let ((subject (mail-fetch-field "subject"))
+ (body (buffer-substring (save-excursion
+ (rfc822-goto-eoh)
+ (point))
+ (point-max))))
+ (when (diary-from-outlook-internal t)
+ (when (or (interactive-p)
+ (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
+
+
(provide 'diary-lib)
;;; arch-tag: 22dd506e-2e33-410d-9ae1-095a0c1b2010
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
index b262ac50a38..71f73f24b75 100644
--- a/lisp/calendar/holidays.el
+++ b/lisp/calendar/holidays.el
@@ -84,6 +84,10 @@
"Holiday on MONTH, DAY (Islamic) called STRING."
t)
+(autoload 'holiday-bahai "cal-bahai"
+ "Holiday on MONTH, DAY (Baha'i) called STRING."
+ t)
+
(autoload 'holiday-chinese-new-year "cal-china"
"Date of Chinese New Year."
t)
@@ -141,6 +145,7 @@ The optional LABEL is used to label the buffer created."
(if christian-holidays (cons "Christian" christian-holidays))
(if hebrew-holidays (cons "Hebrew" hebrew-holidays))
(if islamic-holidays (cons "Islamic" islamic-holidays))
+ (if bahai-holidays (cons "Baha'i" bahai-holidays))
(if oriental-holidays (cons "Oriental" oriental-holidays))
(if solar-holidays (cons "Solar" solar-holidays))
(cons "Ask" nil)))
diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el
index b36d5ab2f31..846231befe6 100644
--- a/lisp/calendar/time-date.el
+++ b/lisp/calendar/time-date.el
@@ -149,7 +149,7 @@ DATE1 and DATE2 should be date-time strings."
;;;###autoload
(defun time-to-day-in-year (time)
- "Return the day number within the year of the date month/day/year."
+ "Return the day number within the year corresponding to TIME."
(let* ((tim (decode-time time))
(month (nth 4 tim))
(day (nth 3 tim))
diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el
index 0507ddab64a..709ea25fbcb 100644
--- a/lisp/calendar/timeclock.el
+++ b/lisp/calendar/timeclock.el
@@ -1129,12 +1129,6 @@ discrepancy, today's discrepancy, and the time worked today."
;;; A reporting function that uses timeclock-log-data
-(defun timeclock-time-less-p (t1 t2)
- "Say whether time T1 is less than time T2."
- (or (< (car t1) (car t2))
- (and (= (car t1) (car t2))
- (< (nth 1 t1) (nth 1 t2)))))
-
(defun timeclock-day-base (&optional time)
"Given a time within a day, return 0:0:0 within that day.
If optional argument TIME is non-nil, use that instead of the current time."
@@ -1190,12 +1184,12 @@ HTML-P is non-nil, HTML markup is added."
(* 2 7 24 60 60))))
two-week-len today-len)
(while proj-data
- (if (not (timeclock-time-less-p
+ (if (not (time-less-p
(timeclock-entry-begin (car proj-data)) today))
(setq today-len (timeclock-entry-list-length proj-data)
proj-data nil)
(if (and (null two-week-len)
- (not (timeclock-time-less-p
+ (not (time-less-p
(timeclock-entry-begin (car proj-data))
two-weeks-ago)))
(setq two-week-len (timeclock-entry-list-length proj-data)))
@@ -1260,7 +1254,7 @@ HTML-P is non-nil, HTML markup is added."
(while day-list
(let ((i 0) (l 5))
(while (< i l)
- (unless (timeclock-time-less-p
+ (unless (time-less-p
(timeclock-day-begin (car day-list))
(aref lengths i))
(let ((base (timeclock-time-to-seconds
diff --git a/lisp/comint.el b/lisp/comint.el
index 57e785dce47..12d8e1fcbb7 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -171,6 +171,31 @@ Good choices:
This is a good thing to set in mode hooks.")
+(defcustom comint-prompt-read-only nil
+ "If non-nil, the comint prompt is read only.
+The read only region includes the newline before the prompt.
+This does not affect existing prompts.
+Certain derived modes may override this option.
+
+If you set this option to t, then the safe way to temporarily
+override the read-only-ness of comint prompts is to call
+`comint-kill-whole-line' or `comint-kill-region' with no
+narrowing in effect. This way you will be certain that none of
+the remaining prompts will be accidentally messed up. You may
+wish to put something like the following in your `.emacs' file:
+
+\(add-hook 'comint-mode-hook
+ '(lambda ()
+ (define-key comint-mode-map \"\C-w\" 'comint-kill-region)
+ (define-key comint-mode-map [C-S-backspace]
+ 'comint-kill-whole-line)))
+
+If you sometimes use comint-mode on text-only terminals or with `emacs-nw',
+you might wish to use another binding for `comint-kill-whole-line'."
+ :type 'boolean
+ :group 'comint
+ :version "21.4")
+
(defvar comint-delimiter-argument-list ()
"List of characters to recognise as separate arguments in input.
Strings comprising a character in this list will separate the arguments
@@ -1157,7 +1182,7 @@ start of the text to scan for history references, rather
than the logical beginning of line."
(save-excursion
(let ((toend (- (line-end-position) (point)))
- (start (comint-line-beginning-position)))
+ (start (or start (comint-line-beginning-position))))
(goto-char start)
(while (progn
(skip-chars-forward "^!^" (- (line-end-position) toend))
@@ -1457,7 +1482,8 @@ Similarly for Soar, Scheme, etc."
(concat input "\n")))
(let ((beg (marker-position pmark))
- (end (if no-newline (point) (1- (point)))))
+ (end (if no-newline (point) (1- (point))))
+ (inhibit-modification-hooks t))
(when (> end beg)
;; Set text-properties for the input field
(add-text-properties
@@ -1553,7 +1579,8 @@ See `comint-carriage-motion' for details.")
freeze its attributes in place, even when more input comes a long
and moves the prompt overlay."
(when comint-last-prompt-overlay
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
(add-text-properties (overlay-start comint-last-prompt-overlay)
(overlay-end comint-last-prompt-overlay)
(overlay-properties comint-last-prompt-overlay)))))
@@ -1684,19 +1711,30 @@ Make backspaces delete the previous character."
(goto-char (process-mark process)) ; in case a filter moved it
(unless comint-use-prompt-regexp-instead-of-fields
- (let ((inhibit-read-only t))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
(add-text-properties comint-last-output-start (point)
'(rear-nonsticky t
- field output
- inhibit-line-move-field-capture t))))
+ field output
+ inhibit-line-move-field-capture t))))
;; Highlight the prompt, where we define `prompt' to mean
;; the most recent output that doesn't end with a newline.
- (unless (and (bolp) (null comint-last-prompt-overlay))
- ;; Need to create or move the prompt overlay (in the case
- ;; where there is no prompt ((bolp) == t), we still do
- ;; this if there's already an existing overlay).
- (let ((prompt-start (save-excursion (forward-line 0) (point))))
+ (let ((prompt-start (save-excursion (forward-line 0) (point)))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (when comint-prompt-read-only
+ (or (= (point-min) prompt-start)
+ (get-text-property (1- prompt-start) 'read-only)
+ (put-text-property
+ (1- prompt-start) prompt-start 'read-only 'fence))
+ (add-text-properties
+ prompt-start (point)
+ '(read-only t rear-non-sticky t front-sticky (read-only))))
+ (unless (and (bolp) (null comint-last-prompt-overlay))
+ ;; Need to create or move the prompt overlay (in the case
+ ;; where there is no prompt ((bolp) == t), we still do
+ ;; this if there's already an existing overlay).
(if comint-last-prompt-overlay
;; Just move an existing overlay
(move-overlay comint-last-prompt-overlay
@@ -2006,7 +2044,8 @@ This function could be in the list `comint-output-filter-functions'."
Does not delete the prompt."
(interactive)
(let ((proc (get-buffer-process (current-buffer)))
- (replacement nil))
+ (replacement nil)
+ (inhibit-read-only t))
(save-excursion
(let ((pmark (progn (goto-char (process-mark proc))
(forward-line 0)
@@ -2293,6 +2332,84 @@ This command is like `M-.' in bash."
(just-one-space)))
+;; Support editing with `comint-prompt-read-only' set to t.
+
+(defun comint-update-fence ()
+ "Update read-only status of newline before point.
+The `fence' read-only property is used to indicate that a newline
+is read-only for no other reason than to \"fence off\" a
+following front-sticky read-only region. This is used to
+implement comint read-only prompts. If the text after a newline
+changes, the read-only status of that newline may need updating.
+That is what this function does.
+
+This function does nothing if point is not at the beginning of a
+line, or is at the beginning of the accessible portion of the buffer.
+Otherwise, if the character after point has a front-sticky
+read-only property, then the preceding newline is given a
+read-only property of `fence', unless it already is read-only.
+If the character after point does not have a front-sticky
+read-only property, any read-only property of `fence' on the
+preceding newline is removed."
+ (let* ((pt (point)) (lst (get-text-property pt 'front-sticky))
+ (inhibit-modification-hooks t))
+ (and (bolp)
+ (not (bobp))
+ (if (and (get-text-property pt 'read-only)
+ (if (listp lst) (memq 'read-only lst) t))
+ (unless (get-text-property (1- pt) 'read-only)
+ (put-text-property (1- pt) pt 'read-only 'fence))
+ (when (eq (get-text-property (1- pt) 'read-only) 'fence)
+ (remove-list-of-text-properties (1- pt) pt '(read-only)))))))
+
+(defun comint-kill-whole-line (&optional arg)
+ "Kill current line, ignoring read-only and field properties.
+With prefix arg, kill that many lines starting from the current line.
+If arg is negative, kill backward. Also kill the preceding newline,
+instead of the trailing one. \(This is meant to make C-x z work well
+with negative arguments.)
+If arg is zero, kill current line but exclude the trailing newline.
+The read-only status of newlines is updated with `comint-update-fence',
+if necessary."
+ (interactive "p")
+ (let ((inhibit-read-only t) (inhibit-field-text-motion t))
+ (kill-whole-line arg)
+ (when (>= arg 0) (comint-update-fence))))
+
+(defun comint-kill-region (beg end &optional yank-handler)
+ "Like `kill-region', but ignores read-only properties, if safe.
+This command assumes that the buffer contains read-only
+\"prompts\" which are regions with front-sticky read-only
+properties at the beginning of a line, with the preceding newline
+being read-only to protect the prompt. This is true of the
+comint prompts if `comint-prompt-read-only' is non-nil. This
+command will not delete the region if this would create mutilated
+or out of place prompts. That is, if any part of a prompt is
+deleted, the entire prompt must be deleted and all remaining
+prompts should stay at the beginning of a line. If this is not
+the case, this command just calls `kill-region' with all
+read-only properties intact. The read-only status of newlines is
+updated using `comint-update-fence', if necessary."
+ (interactive "r")
+ (save-excursion
+ (let* ((true-beg (min beg end))
+ (true-end (max beg end))
+ (beg-bolp (progn (goto-char true-beg) (bolp)))
+ (beg-lst (get-text-property true-beg 'front-sticky))
+ (beg-bad (and (get-text-property true-beg 'read-only)
+ (if (listp beg-lst) (memq 'read-only beg-lst) t)))
+ (end-bolp (progn (goto-char true-end) (bolp)))
+ (end-lst (get-text-property true-end 'front-sticky))
+ (end-bad (and (get-text-property true-end 'read-only)
+ (if (listp end-lst) (memq 'read-only end-lst) t))))
+ (if (or (and (not beg-bolp) (or beg-bad end-bad))
+ (and (not end-bolp) end-bad))
+ (kill-region beg end yank-handler)
+ (let ((inhibit-read-only t))
+ (kill-region beg end yank-handler)
+ (comint-update-fence))))))
+
+
;; Support for source-file processing commands.
;;============================================================================
;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
@@ -2854,10 +2971,8 @@ Typing SPC flushes the help buffer."
;; Read the next key, to process SPC.
(let (key first)
- (if (save-excursion
- (set-buffer (get-buffer "*Completions*"))
- (set (make-local-variable
- 'comint-displayed-dynamic-completions)
+ (if (with-current-buffer (get-buffer "*Completions*")
+ (set (make-local-variable 'comint-displayed-dynamic-completions)
completions)
(setq key (read-key-sequence nil)
first (aref key 0))
diff --git a/lisp/compare-w.el b/lisp/compare-w.el
index d283016750f..7e23c9efedf 100644
--- a/lisp/compare-w.el
+++ b/lisp/compare-w.el
@@ -1,6 +1,6 @@
;;; compare-w.el --- compare text between windows for Emacs
-;; Copyright (C) 1986, 1989, 1993, 1997, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1986,1989,1993,1997,2003,2004 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: convenience files
@@ -117,12 +117,12 @@ and the value `((4) (4))' for horizontally split windows."
:group 'compare-w)
(defface compare-windows-face
- '((((type tty pc) (class color))
- (:background "turquoise3"))
- (((class color) (background light))
+ '((((class color) (min-colors 88) (background light))
(:background "paleturquoise"))
- (((class color) (background dark))
+ (((class color) (min-colors 88) (background dark))
(:background "paleturquoise4"))
+ (((class color))
+ (:background "turquoise3"))
(t (:underline t)))
"Face for highlighting of compare-windows difference regions."
:group 'compare-w)
diff --git a/lisp/completion.el b/lisp/completion.el
index 2fb0ef0a3b2..d7f728821f9 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -1,6 +1,6 @@
;;; completion.el --- dynamic word-completion code
-;; Copyright (C) 1990, 1993, 1995, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1990, 1993, 1995, 1997, 2004 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: abbrev convenience
@@ -2251,7 +2251,7 @@ The command \\[yank] can retrieve it from there.
/(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
This is the primitive for programs to kill text (as opposed to deleting it).
-Supply two arguments, character numbers indicating the stretch of text
+Supply two arguments, character positions indicating the stretch of text
to be killed.
Any command that calls this function is a \"kill command\".
If the previous command was also a kill command,
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 951b14f7f05..9e0efc5d3d0 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -1012,11 +1012,11 @@ version."
;;;###autoload
(defun customize-face (&optional face)
- "Customize SYMBOL, which should be a face name or nil.
-If SYMBOL is nil, customize all faces.
+ "Customize FACE, which should be a face name or nil.
+If FACE is nil, customize all faces.
Interactively, when point is on text which has a face specified,
-suggest to customized that face, if it's customizable."
+suggest to customize that face, if it's customizable."
(interactive
(list (read-face-name "Customize face" "all faces" t)))
(if (member face '(nil ""))
@@ -1038,10 +1038,10 @@ suggest to customized that face, if it's customizable."
;;;###autoload
(defun customize-face-other-window (&optional face)
- "Show customization buffer for face SYMBOL in other window.
+ "Show customization buffer for face FACE in other window.
Interactively, when point is on text which has a face specified,
-suggest to customized that face, if it's customizable."
+suggest to customize that face, if it's customizable."
(interactive
(list (read-face-name "Customize face" "all faces" t)))
(if (member face '(nil ""))
@@ -1093,7 +1093,7 @@ suggest to customized that face, if it's customizable."
(get symbol 'standard-value))))
(when (and cval ;Declared with defcustom.
(default-boundp symbol) ;Has a value.
- (not (equal (eval (car cval))
+ (not (equal (eval (car cval))
;; Which does not match customize.
(default-value symbol))))
(push (list symbol 'custom-variable) found)))))
@@ -1876,7 +1876,7 @@ and `face'."
(custom-load-symbol (widget-value widget)))
(defun custom-unloaded-symbol-p (symbol)
- "Return non-nil if the dependencies of SYMBOL has not yet been loaded."
+ "Return non-nil if the dependencies of SYMBOL have not yet been loaded."
(let ((found nil)
(loads (get symbol 'custom-loads))
load)
@@ -1894,7 +1894,7 @@ and `face'."
found))
(defun custom-unloaded-widget-p (widget)
- "Return non-nil if the dependencies of WIDGET has not yet been loaded."
+ "Return non-nil if the dependencies of WIDGET have not yet been loaded."
(custom-unloaded-symbol-p (widget-value widget)))
(defun custom-toggle-hide (widget)
@@ -2074,11 +2074,25 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"."
:group 'custom-buffer
:version "20.3")
+(defun custom-variable-documentation (variable)
+ "Return documentation of VARIABLE for use in Custom buffer.
+Normally just return the docstring. But if VARIABLE automatically
+becomes buffer local when set, append a message to that effect."
+ (if (and (local-variable-if-set-p variable)
+ (or (not (local-variable-p variable))
+ (with-temp-buffer
+ (local-variable-if-set-p variable))))
+ (concat (documentation-property variable 'variable-documentation)
+ "\n
+This variable automatically becomes buffer-local when set outside Custom.
+However, setting it through Custom sets the default value.")
+ (documentation-property variable 'variable-documentation)))
+
(define-widget 'custom-variable 'custom
"Customize variable."
:format "%v"
:help-echo "Set or reset this variable."
- :documentation-property 'variable-documentation
+ :documentation-property #'custom-variable-documentation
:custom-category 'option
:custom-state nil
:custom-menu 'custom-variable-menu-create
@@ -2646,7 +2660,7 @@ Also change :reverse-video to :inverse-video."
(widget-setup)))))
(defun custom-face-edit-delete (widget)
- "Remove widget from the buffer."
+ "Remove WIDGET from the buffer."
(let ((inactive (widget-get widget :inactive))
(inhibit-read-only t)
(inhibit-modification-hooks t))
@@ -2729,6 +2743,10 @@ Match grayscale frames.")
Match frames with no color support.")
mono)))
(group :sibling-args (:help-echo "\
+The minimum number of colors the frame should support.")
+ (const :format "" min-colors)
+ (integer :tag "Minimum number of colors" ))
+ (group :sibling-args (:help-echo "\
Only match frames with the specified intensity.")
(const :format "\
Background brightness: "
@@ -4023,6 +4041,7 @@ The format is suitable for use with `easy-menu-define'."
(suppress-keymap custom-mode-map)
(define-key custom-mode-map " " 'scroll-up)
(define-key custom-mode-map "\177" 'scroll-down)
+ (define-key custom-mode-map "\C-x\C-s" 'Custom-save)
(define-key custom-mode-map "q" 'Custom-buffer-done)
(define-key custom-mode-map "u" 'Custom-goto-parent)
(define-key custom-mode-map "n" 'widget-forward)
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 1ff07c4c361..e3134e8f1ea 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -39,15 +39,11 @@
(when (fboundp 'facep)
(unless (facep face)
;; If the user has already created the face, respect that.
- (let ((value (or (get face 'saved-face) spec))
- (frames (frame-list))
- frame)
+ (let ((value (or (get face 'saved-face) spec)))
;; Create global face.
(make-empty-face face)
;; Create frame-local faces
- (while frames
- (setq frame (car frames)
- frames (cdr frames))
+ (dolist (frame (frame-list))
(face-spec-set face value frame)))
;; When making a face after frames already exist
(if (memq window-system '(x w32))
diff --git a/lisp/custom.el b/lisp/custom.el
index f5cfd55400a..e86308c95e7 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -54,7 +54,7 @@ Users should not set it.")
"Initialize SYMBOL with VALUE.
This will do nothing if symbol already has a default binding.
Otherwise, if symbol has a `saved-value' property, it will evaluate
-the car of that and used as the default binding for symbol.
+the car of that and use it as the default binding for symbol.
Otherwise, VALUE will be evaluated and used as the default binding for
symbol."
(unless (default-boundp symbol)
@@ -176,7 +176,7 @@ set to nil, as the value is no longer rogue."
"Declare SYMBOL as a customizable variable that defaults to VALUE.
DOC is the variable documentation.
-Neither SYMBOL nor VALUE needs to be quoted.
+Neither SYMBOL nor VALUE need to be quoted.
If SYMBOL is not already bound, initialize it to VALUE.
The remaining arguments should have the form
@@ -298,8 +298,8 @@ following REQ are defined:
`type' (the value of `window-system')
Under X, in addition to the values `window-system' can take,
- `motif', `lucid' and `x-toolkit' are allowed, and match when
- the Motif toolkit, Lucid toolkit, or any X toolkit is in use.
+ `motif', `lucid', `gtk' and `x-toolkit' are allowed, and match when
+ the Motif toolkit, Lucid toolkit, GTK toolkit or any X toolkit is in use.
`class' (the frame's color support)
Should be one of `color', `grayscale', or `mono'.
@@ -311,6 +311,11 @@ following REQ are defined:
Should be an integer, it is compared with the result of
`display-color-cells'.
+`supports' (only match frames that support the specified face attributes)
+ Should be a list of face attributes. See the documentation for
+ the function `display-supports-face-attributes-p' for more
+ information on exactly how testing is done.
+
Read the section about customization in the Emacs Lisp manual for more
information."
;; It is better not to use backquote in this file,
diff --git a/lisp/cvs-status.el b/lisp/cvs-status.el
index 528ab74e509..b03182d87e4 100644
--- a/lisp/cvs-status.el
+++ b/lisp/cvs-status.el
@@ -1,4 +1,4 @@
-;;; cvs-status.el --- major mode for browsing `cvs status' output
+;;; cvs-status.el --- major mode for browsing `cvs status' output -*- coding: utf-8 -*-
;; Copyright (C) 1999, 2000, 03, 2004 Free Software Foundation, Inc.
@@ -277,10 +277,10 @@ BEWARE: because of stability issues, this is not a symetric operation."
(cvs-tree-merge (cdr tree1) (cdr tree2))))))
((> l1 l2)
(cvs-tree-merge
- (list (cons (cvs-tag-make (cvs-butlast vl1)) tree1)) tree2))
+ (list (cons (cvs-tag-make (butlast vl1)) tree1)) tree2))
((< l1 l2)
(cvs-tree-merge
- tree1 (list (cons (cvs-tag-make (cvs-butlast vl2)) tree2)))))))))
+ tree1 (list (cons (cvs-tag-make (butlast vl2)) tree2)))))))))
(defun cvs-tag-make-tag (tag)
(let ((vl (mapcar 'string-to-number (split-string (nth 2 tag) "\\."))))
@@ -293,7 +293,7 @@ BEWARE: because of stability issues, this is not a symetric operation."
(lambda (tag)
(let ((tag (cvs-tag-make-tag tag)))
(list (if (not (eq (cvs-tag->type tag) 'branch)) tag
- (list (cvs-tag-make (cvs-butlast (cvs-tag->vlist tag)))
+ (list (cvs-tag-make (butlast (cvs-tag->vlist tag)))
tag)))))
tags)))
(while (cdr tags)
@@ -384,23 +384,45 @@ the list is a three-string list TAG, KIND, REV."
;;;; CVSTree-style trees
;;;;
-(defvar cvs-tree-use-jisx0208
- (and (char-displayable-p (make-char 'japanese-jisx0208 40 44)) t)
+(defvar cvs-tree-use-jisx0208 nil) ;Old compat var.
+(defvar cvs-tree-use-charset
+ (cond
+ (cvs-tree-use-jisx0208 'jisx0208)
+ ((char-displayable-p ?━) 'unicode)
+ ((char-displayable-p (make-char 'japanese-jisx0208 40 44)) 'jisx0208))
"*Non-nil if we should use the graphical glyphs from `japanese-jisx0208'.
Otherwise, default to ASCII chars like +, - and |.")
(defconst cvs-tree-char-space
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 33 33) " "))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 33 33))
+ (unicode " ")
+ (t " ")))
(defconst cvs-tree-char-hbar
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 44) "--"))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 44))
+ (unicode "━")
+ (t "--")))
(defconst cvs-tree-char-vbar
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 45) "| "))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 45))
+ (unicode "┃")
+ (t "| ")))
(defconst cvs-tree-char-branch
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 50) "+-"))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 50))
+ (unicode "┣")
+ (t "+-")))
(defconst cvs-tree-char-eob ;end of branch
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 49) "`-"))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 49))
+ (unicode "┗")
+ (t "`-")))
(defconst cvs-tree-char-bob ;beginning of branch
- (if cvs-tree-use-jisx0208 (make-char 'japanese-jisx0208 40 51) "+-"))
+ (case cvs-tree-use-charset
+ (jisx0208 (make-char 'japanese-jisx0208 40 51))
+ (unicode "┳")
+ (t "+-")))
(defun cvs-tag-lessp (tag1 tag2)
(eq (cvs-tag-compare tag1 tag2) 'more2))
@@ -411,7 +433,7 @@ Otherwise, default to ASCII chars like +, - and |.")
"Look for a list of tags, and replace it with a tree.
Optional prefix ARG chooses between two representations."
(interactive "P")
- (when (and cvs-tree-use-jisx0208
+ (when (and cvs-tree-use-charset
(not enable-multibyte-characters))
;; We need to convert the buffer from unibyte to multibyte
;; since we'll use multibyte chars for the tree.
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el
index 3763f2ccab8..47ffba9873d 100644
--- a/lisp/dabbrev.el
+++ b/lisp/dabbrev.el
@@ -888,23 +888,28 @@ to record whether we upcased the expansion, downcased it, or did neither."
;; matches the start of the expansion,
;; copy the expansion's case
;; instead of downcasing all the rest.
- ;; Treat a one-capital-letter abbrev as "not all upper case",
- ;; so as to force preservation of the expansion's pattern
- ;; if the expansion starts with a capital letter.
- (let ((expansion-rest (substring expansion 1)))
- (if (and (not (and (or (string= expansion-rest (downcase expansion-rest))
- (string= expansion-rest (upcase expansion-rest)))
- (or (string= abbrev (downcase abbrev))
- (and (string= abbrev (upcase abbrev))
- (> (length abbrev) 1)))))
- (string= abbrev
- (substring expansion 0 (length abbrev))))
+ ;;
+ ;; Treat a one-capital-letter (possibly with preceding non-letter
+ ;; characters) abbrev as "not all upper case", so as to force
+ ;; preservation of the expansion's pattern if the expansion starts
+ ;; with a capital letter.
+ (let ((expansion-rest (substring expansion 1))
+ (first-letter-position (string-match "[[:alpha:]]" abbrev)))
+ (if (or (null first-letter-position)
+ (and (not (and (or (string= expansion-rest (downcase expansion-rest))
+ (string= expansion-rest (upcase expansion-rest)))
+ (or (string= abbrev (downcase abbrev))
+ (and (string= abbrev (upcase abbrev))
+ (> (- (length abbrev) first-letter-position)
+ 1)))))
+ (string= abbrev
+ (substring expansion 0 (length abbrev)))))
(setq use-case-replace nil)))
;; If the abbrev and the expansion are both all-lower-case
;; then don't do any conversion. The conversion would be a no-op
;; for this replacement, but it would carry forward to subsequent words.
- ;; The goal of this is to preven that carrying forward.
+ ;; The goal of this is to prevent that carrying forward.
(if (and (string= expansion (downcase expansion))
(string= abbrev (downcase abbrev)))
(setq use-case-replace nil))
diff --git a/lisp/delsel.el b/lisp/delsel.el
index 88e23cb218e..d8e034a5f9f 100644
--- a/lisp/delsel.el
+++ b/lisp/delsel.el
@@ -123,8 +123,6 @@ any selection."
(put 'newline 'delete-selection t)
(put 'open-line 'delete-selection 'kill)
-(put 'insert-parentheses 'delete-selection t)
-
;; This is very useful for cancelling a selection in the minibuffer without
;; aborting the minibuffer.
(defun minibuffer-keyboard-quit ()
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index 7e90e989b3e..5ce8cabed55 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -28,7 +28,7 @@
;;; Code:
-(eval-when-compile (require 'button))
+(eval-when-compile (require 'button) (require 'quail))
(defun describe-text-done ()
"Delete the current window or bury the current buffer."
@@ -111,7 +111,8 @@ into widget buttons that call `describe-text-category' or
(setq key (pop properties)
val (pop properties)
len 0)
- (unless (or (memq key '(category face font-lock-face))
+ (unless (or (memq key '(category face font-lock-face
+ syntax-table))
(widgetp val))
(setq val (pp-to-string val)
len (length val)))
@@ -134,7 +135,15 @@ into widget buttons that call `describe-text-category' or
:notify `(lambda (&rest ignore)
(describe-face ',value))
(format "%S" value)))
- ((widgetp value)
+ ((eq key 'syntax-table)
+ (widget-create 'push-button
+ :tag "show"
+ :action (lambda (widget &optional event)
+ (with-output-to-temp-buffer
+ "*Pp Eval Output*"
+ (pp (widget-get widget :value))))
+ value))
+ ((widgetp value)
(describe-text-widget value))
(t
(widget-insert value))))
@@ -183,7 +192,6 @@ otherwise."
(defun describe-text-properties-1 (pos output-buffer)
(let* ((properties (text-properties-at pos))
(overlays (overlays-at pos))
- overlay
(wid-field (get-char-property pos 'field))
(wid-button (get-char-property pos 'button))
(wid-doc (get-char-property pos 'widget-doc))
@@ -225,221 +233,214 @@ otherwise."
(widget-insert "There are text properties here:\n")
(describe-property-list properties)))))
-;;; We cannot use the UnicodeData.txt file as such; it is not free.
-;;; We can turn that info a different format and release the result
-;;; as free data. When that is done, we could reinstate the code below.
-;;; For the mean time, here is a dummy placeholder.
-;;; -- rms
-(defun describe-char-unicode-data (char) nil)
-
-;;; (defcustom describe-char-unicodedata-file nil
-;;; "Location of Unicode data file.
-;;; This is the UnicodeData.txt file from the Unicode consortium, used for
-;;; diagnostics. If it is non-nil `describe-char-after' will print data
-;;; looked up from it. This facility is mostly of use to people doing
-;;; multilingual development.
-
-;;; This is a fairly large file, not typically present on GNU systems. At
-;;; the time of writing it is at
-;;; <URL:ftp://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
-;;; :group 'mule
-;;; :version "21.5"
-;;; :type '(choice (const :tag "None" nil)
-;;; file))
-
-;;; ;; We could convert the unidata file into a Lispy form once-for-all
-;;; ;; and distribute it for loading on demand. It might be made more
-;;; ;; space-efficient by splitting strings word-wise and replacing them
-;;; ;; with lists of symbols interned in a private obarray, e.g.
-;;; ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
-
-;;; ;; Fixme: Check whether this needs updating for Unicode 4.
-;;; (defun describe-char-unicode-data (char)
-;;; "Return a list of Unicode data for unicode CHAR.
-;;; Each element is a list of a property description and the property value.
-;;; The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
-;;; (when describe-char-unicodedata-file
-;;; (unless (file-exists-p describe-char-unicodedata-file)
-;;; (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
-;;; (save-excursion
-;;; ;; Find file in fundamental mode to avoid, e.g. flyspell turned
-;;; ;; on for .txt. Don't use RAWFILE arg in case of DOS line endings.
-;;; (set-buffer (let ((auto-mode-alist))
-;;; (find-file-noselect describe-char-unicodedata-file)))
-;;; (goto-char (point-min))
-;;; (let ((hex (format "%04X" char))
-;;; found first last)
-;;; (if (re-search-forward (concat "^" hex) nil t)
-;;; (setq found t)
-;;; ;; It's not listed explicitly. Look for ranges, e.g. CJK
-;;; ;; ideographs, and check whether it's in one of them.
-;;; (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
-;;; (>= char (setq first
-;;; (string-to-number (match-string 1) 16)))
-;;; (progn
-;;; (forward-line 1)
-;;; (looking-at "^\\([^;]+\\);[^;]+Last>;")
-;;; (> char
-;;; (setq last
-;;; (string-to-number (match-string 1) 16))))))
-;;; (if (and (>= char first)
-;;; (<= char last))
-;;; (setq found t)))
-;;; (if found
-;;; (let ((fields (mapcar (lambda (elt)
-;;; (if (> (length elt) 0)
-;;; elt))
-;;; (cdr (split-string
-;;; (buffer-substring
-;;; (line-beginning-position)
-;;; (line-end-position))
-;;; ";")))))
-;;; ;; The length depends on whether the last field was empty.
-;;; (unless (or (= 13 (length fields))
-;;; (= 14 (length fields)))
-;;; (error "Invalid contents in %s" describe-char-unicodedata-file))
-;;; ;; The field names and values lists are slightly
-;;; ;; modified from Mule-UCS unidata.el.
-;;; (list
-;;; (list "Name" (let ((name (nth 0 fields)))
-;;; ;; Check for <..., First>, <..., Last>
-;;; (if (string-match "\\`\\(<[^,]+\\)," name)
-;;; (concat (match-string 1 name) ">")
-;;; name)))
-;;; (list "Category"
-;;; (cdr (assoc
-;;; (nth 1 fields)
-;;; '(("Lu" . "uppercase letter")
-;;; ("Ll" . "lowercase letter")
-;;; ("Lt" . "titlecase letter")
-;;; ("Mn" . "non-spacing mark")
-;;; ("Mc" . "spacing-combining mark")
-;;; ("Me" . "enclosing mark")
-;;; ("Nd" . "decimal digit")
-;;; ("Nl" . "letter number")
-;;; ("No" . "other number")
-;;; ("Zs" . "space separator")
-;;; ("Zl" . "line separator")
-;;; ("Zp" . "paragraph separator")
-;;; ("Cc" . "other control")
-;;; ("Cf" . "other format")
-;;; ("Cs" . "surrogate")
-;;; ("Co" . "private use")
-;;; ("Cn" . "not assigned")
-;;; ("Lm" . "modifier letter")
-;;; ("Lo" . "other letter")
-;;; ("Pc" . "connector punctuation")
-;;; ("Pd" . "dash punctuation")
-;;; ("Ps" . "open punctuation")
-;;; ("Pe" . "close punctuation")
-;;; ("Pi" . "initial-quotation punctuation")
-;;; ("Pf" . "final-quotation punctuation")
-;;; ("Po" . "other punctuation")
-;;; ("Sm" . "math symbol")
-;;; ("Sc" . "currency symbol")
-;;; ("Sk" . "modifier symbol")
-;;; ("So" . "other symbol")))))
-;;; (list "Combining class"
-;;; (cdr (assoc
-;;; (string-to-number (nth 2 fields))
-;;; '((0 . "Spacing")
-;;; (1 . "Overlays and interior")
-;;; (7 . "Nuktas")
-;;; (8 . "Hiragana/Katakana voicing marks")
-;;; (9 . "Viramas")
-;;; (10 . "Start of fixed position classes")
-;;; (199 . "End of fixed position classes")
-;;; (200 . "Below left attached")
-;;; (202 . "Below attached")
-;;; (204 . "Below right attached")
-;;; (208 . "Left attached (reordrant around \
-;;; single base character)")
-;;; (210 . "Right attached")
-;;; (212 . "Above left attached")
-;;; (214 . "Above attached")
-;;; (216 . "Above right attached")
-;;; (218 . "Below left")
-;;; (220 . "Below")
-;;; (222 . "Below right")
-;;; (224 . "Left (reordrant around single base \
-;;; character)")
-;;; (226 . "Right")
-;;; (228 . "Above left")
-;;; (230 . "Above")
-;;; (232 . "Above right")
-;;; (233 . "Double below")
-;;; (234 . "Double above")
-;;; (240 . "Below (iota subscript)")))))
-;;; (list "Bidi category"
-;;; (cdr (assoc
-;;; (nth 3 fields)
-;;; '(("L" . "Left-to-Right")
-;;; ("LRE" . "Left-to-Right Embedding")
-;;; ("LRO" . "Left-to-Right Override")
-;;; ("R" . "Right-to-Left")
-;;; ("AL" . "Right-to-Left Arabic")
-;;; ("RLE" . "Right-to-Left Embedding")
-;;; ("RLO" . "Right-to-Left Override")
-;;; ("PDF" . "Pop Directional Format")
-;;; ("EN" . "European Number")
-;;; ("ES" . "European Number Separator")
-;;; ("ET" . "European Number Terminator")
-;;; ("AN" . "Arabic Number")
-;;; ("CS" . "Common Number Separator")
-;;; ("NSM" . "Non-Spacing Mark")
-;;; ("BN" . "Boundary Neutral")
-;;; ("B" . "Paragraph Separator")
-;;; ("S" . "Segment Separator")
-;;; ("WS" . "Whitespace")
-;;; ("ON" . "Other Neutrals")))))
-;;; (list
-;;; "Decomposition"
-;;; (if (nth 4 fields)
-;;; (let* ((parts (split-string (nth 4 fields)))
-;;; (info (car parts)))
-;;; (if (string-match "\\`<\\(.+\\)>\\'" info)
-;;; (setq info (match-string 1 info))
-;;; (setq info nil))
-;;; (if info (setq parts (cdr parts)))
-;;; ;; Maybe printing ? for unrepresentable unicodes
-;;; ;; here and below should be changed?
-;;; (setq parts (mapconcat
-;;; (lambda (arg)
-;;; (string (or (decode-char
-;;; 'ucs
-;;; (string-to-number arg 16))
-;;; ??)))
-;;; parts " "))
-;;; (concat info parts))))
-;;; (list "Decimal digit value"
-;;; (nth 5 fields))
-;;; (list "Digit value"
-;;; (nth 6 fields))
-;;; (list "Numeric value"
-;;; (nth 7 fields))
-;;; (list "Mirrored"
-;;; (if (equal "Y" (nth 8 fields))
-;;; "yes"))
-;;; (list "Old name" (nth 9 fields))
-;;; (list "ISO 10646 comment" (nth 10 fields))
-;;; (list "Uppercase" (and (nth 11 fields)
-;;; (string (or (decode-char
-;;; 'ucs
-;;; (string-to-number
-;;; (nth 11 fields) 16))
-;;; ??))))
-;;; (list "Lowercase" (and (nth 12 fields)
-;;; (string (or (decode-char
-;;; 'ucs
-;;; (string-to-number
-;;; (nth 12 fields) 16))
-;;; ??))))
-;;; (list "Titlecase" (and (nth 13 fields)
-;;; (string (or (decode-char
-;;; 'ucs
-;;; (string-to-number
-;;; (nth 13 fields) 16))
-;;; ??)))))))))))
+(defcustom describe-char-unicodedata-file nil
+ "Location of Unicode data file.
+This is the UnicodeData.txt file from the Unicode consortium, used for
+diagnostics. If it is non-nil `describe-char-after' will print data
+looked up from it. This facility is mostly of use to people doing
+multilingual development.
+
+This is a fairly large file, not typically present on GNU systems. At
+the time of writing it is at
+<URL:http://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
+ :group 'mule
+ :version "21.4"
+ :type '(choice (const :tag "None" nil)
+ file))
+
+;; We could convert the unidata file into a Lispy form once-for-all
+;; and distribute it for loading on demand. It might be made more
+;; space-efficient by splitting strings word-wise and replacing them
+;; with lists of symbols interned in a private obarray, e.g.
+;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
+
+;; Fixme: Check whether this needs updating for Unicode 4.
+(defun describe-char-unicode-data (char)
+ "Return a list of Unicode data for unicode CHAR.
+Each element is a list of a property description and the property value.
+The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
+ (when describe-char-unicodedata-file
+ (unless (file-exists-p describe-char-unicodedata-file)
+ (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
+ (with-current-buffer
+ ;; Find file in fundamental mode to avoid, e.g. flyspell turned
+ ;; on for .txt. Don't use RAWFILE arg in case of DOS line endings.
+ (let ((auto-mode-alist))
+ (find-file-noselect describe-char-unicodedata-file))
+ (goto-char (point-min))
+ (let ((hex (format "%04X" char))
+ found first last)
+ (if (re-search-forward (concat "^" hex) nil t)
+ (setq found t)
+ ;; It's not listed explicitly. Look for ranges, e.g. CJK
+ ;; ideographs, and check whether it's in one of them.
+ (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
+ (>= char (setq first
+ (string-to-number (match-string 1) 16)))
+ (progn
+ (forward-line 1)
+ (looking-at "^\\([^;]+\\);[^;]+Last>;")
+ (> char
+ (setq last
+ (string-to-number (match-string 1) 16))))))
+ (if (and (>= char first)
+ (<= char last))
+ (setq found t)))
+ (if found
+ (let ((fields (mapcar (lambda (elt)
+ (if (> (length elt) 0)
+ elt))
+ (cdr (split-string
+ (buffer-substring
+ (line-beginning-position)
+ (line-end-position))
+ ";")))))
+ ;; The length depends on whether the last field was empty.
+ (unless (or (= 13 (length fields))
+ (= 14 (length fields)))
+ (error "Invalid contents in %s" describe-char-unicodedata-file))
+ ;; The field names and values lists are slightly
+ ;; modified from Mule-UCS unidata.el.
+ (list
+ (list "Name" (let ((name (nth 0 fields)))
+ ;; Check for <..., First>, <..., Last>
+ (if (string-match "\\`\\(<[^,]+\\)," name)
+ (concat (match-string 1 name) ">")
+ name)))
+ (list "Category"
+ (cdr (assoc
+ (nth 1 fields)
+ '(("Lu" . "uppercase letter")
+ ("Ll" . "lowercase letter")
+ ("Lt" . "titlecase letter")
+ ("Mn" . "non-spacing mark")
+ ("Mc" . "spacing-combining mark")
+ ("Me" . "enclosing mark")
+ ("Nd" . "decimal digit")
+ ("Nl" . "letter number")
+ ("No" . "other number")
+ ("Zs" . "space separator")
+ ("Zl" . "line separator")
+ ("Zp" . "paragraph separator")
+ ("Cc" . "other control")
+ ("Cf" . "other format")
+ ("Cs" . "surrogate")
+ ("Co" . "private use")
+ ("Cn" . "not assigned")
+ ("Lm" . "modifier letter")
+ ("Lo" . "other letter")
+ ("Pc" . "connector punctuation")
+ ("Pd" . "dash punctuation")
+ ("Ps" . "open punctuation")
+ ("Pe" . "close punctuation")
+ ("Pi" . "initial-quotation punctuation")
+ ("Pf" . "final-quotation punctuation")
+ ("Po" . "other punctuation")
+ ("Sm" . "math symbol")
+ ("Sc" . "currency symbol")
+ ("Sk" . "modifier symbol")
+ ("So" . "other symbol")))))
+ (list "Combining class"
+ (cdr (assoc
+ (string-to-number (nth 2 fields))
+ '((0 . "Spacing")
+ (1 . "Overlays and interior")
+ (7 . "Nuktas")
+ (8 . "Hiragana/Katakana voicing marks")
+ (9 . "Viramas")
+ (10 . "Start of fixed position classes")
+ (199 . "End of fixed position classes")
+ (200 . "Below left attached")
+ (202 . "Below attached")
+ (204 . "Below right attached")
+ (208 . "Left attached (reordrant around \
+single base character)")
+ (210 . "Right attached")
+ (212 . "Above left attached")
+ (214 . "Above attached")
+ (216 . "Above right attached")
+ (218 . "Below left")
+ (220 . "Below")
+ (222 . "Below right")
+ (224 . "Left (reordrant around single base \
+character)")
+ (226 . "Right")
+ (228 . "Above left")
+ (230 . "Above")
+ (232 . "Above right")
+ (233 . "Double below")
+ (234 . "Double above")
+ (240 . "Below (iota subscript)")))))
+ (list "Bidi category"
+ (cdr (assoc
+ (nth 3 fields)
+ '(("L" . "Left-to-Right")
+ ("LRE" . "Left-to-Right Embedding")
+ ("LRO" . "Left-to-Right Override")
+ ("R" . "Right-to-Left")
+ ("AL" . "Right-to-Left Arabic")
+ ("RLE" . "Right-to-Left Embedding")
+ ("RLO" . "Right-to-Left Override")
+ ("PDF" . "Pop Directional Format")
+ ("EN" . "European Number")
+ ("ES" . "European Number Separator")
+ ("ET" . "European Number Terminator")
+ ("AN" . "Arabic Number")
+ ("CS" . "Common Number Separator")
+ ("NSM" . "Non-Spacing Mark")
+ ("BN" . "Boundary Neutral")
+ ("B" . "Paragraph Separator")
+ ("S" . "Segment Separator")
+ ("WS" . "Whitespace")
+ ("ON" . "Other Neutrals")))))
+ (list
+ "Decomposition"
+ (if (nth 4 fields)
+ (let* ((parts (split-string (nth 4 fields)))
+ (info (car parts)))
+ (if (string-match "\\`<\\(.+\\)>\\'" info)
+ (setq info (match-string 1 info))
+ (setq info nil))
+ (if info (setq parts (cdr parts)))
+ ;; Maybe printing ? for unrepresentable unicodes
+ ;; here and below should be changed?
+ (setq parts (mapconcat
+ (lambda (arg)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number arg 16))
+ ??)))
+ parts " "))
+ (concat info parts))))
+ (list "Decimal digit value"
+ (nth 5 fields))
+ (list "Digit value"
+ (nth 6 fields))
+ (list "Numeric value"
+ (nth 7 fields))
+ (list "Mirrored"
+ (if (equal "Y" (nth 8 fields))
+ "yes"))
+ (list "Old name" (nth 9 fields))
+ (list "ISO 10646 comment" (nth 10 fields))
+ (list "Uppercase" (and (nth 11 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 11 fields) 16))
+ ??))))
+ (list "Lowercase" (and (nth 12 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 12 fields) 16))
+ ??))))
+ (list "Titlecase" (and (nth 13 fields)
+ (string (or (decode-char
+ 'ucs
+ (string-to-number
+ (nth 13 fields) 16))
+ ??)))))))))))
;; Return information about how CHAR is displayed at the buffer
;; position POS. If the selected frame is on a graphic display,
@@ -465,8 +466,7 @@ as well as widgets, buttons, overlays, and text properties."
(if (>= pos (point-max))
(error "No character follows specified position"))
(let* ((char (char-after pos))
- (charset (get-char-property pos 'charset))
- (buffer (current-buffer))
+ (charset (char-charset char))
(composition (find-composition pos nil nil t))
(component-chars nil)
(display-table (or (window-display-table)
@@ -474,116 +474,109 @@ as well as widgets, buttons, overlays, and text properties."
standard-display-table))
(disp-vector (and display-table (aref display-table char)))
(multibyte-p enable-multibyte-characters)
- text-prop-description
- code item-list max-width)
- (or (and (charsetp charset) (encode-char char charset))
- (setq charset (char-charset char)))
- (if (eq charset 'eight-bit)
- (setq item-list
- `(("character"
- ,(format "%s (0%o, %d, 0x%x) -- raw byte 0x%x"
- (char-to-string char) char char char
- (multibyte-char-to-unibyte char)))))
-
- (setq code (encode-char char charset))
- (setq item-list
- `(("character"
- ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)
- (single-key-description char)
- (char-to-string char))
- char char char))
- ("preferred charset"
- ,(symbol-name charset)
- ,(format "(%s)" (charset-description charset)))
- ("code point"
- ,(format (if (< code 256) "0x%02X" "0x%04X") code))
- ("syntax"
- ,(let ((syntax (syntax-after pos)))
- (with-temp-buffer
- (internal-describe-syntax-value syntax)
- (buffer-string))))
- ("category"
- ,@(let ((category-set (char-category-set char)))
- (if (not category-set)
- '("-- none --")
- (mapcar #'(lambda (x) (format "%c:%s "
- x (category-docstring x)))
- (category-set-mnemonics category-set)))))
- ,@(let ((props (aref char-code-property-table char))
- ps)
- (when props
- (while props
- (push (format "%s:" (pop props)) ps)
- (push (format "%s;" (pop props)) ps))
- (list (cons "Properties" (nreverse ps)))))
- ("buffer code"
- ,(encoded-string-description
- (string-as-unibyte (char-to-string char)) nil))
- ("file code"
- ,@(let* ((coding buffer-file-coding-system)
- (encoded (encode-coding-char char coding)))
- (if encoded
- (list (encoded-string-description encoded coding)
- (format "(encoded by coding system %S)" coding))
- (list "not encodable by coding system"
- (symbol-name coding)))))
- ("display"
- ,(cond
- (disp-vector
- (setq disp-vector (copy-sequence disp-vector))
- (dotimes (i (length disp-vector))
- (setq char (aref disp-vector i))
- (aset disp-vector i
- (cons char (describe-char-display pos char))))
- (format "by display table entry [%s] (see below)"
- (mapconcat #'(lambda (x) (format "?%c" (car x)))
- disp-vector " ")))
- (composition
- (let ((from (car composition))
- (to (nth 1 composition))
- (next (1+ pos))
- (components (nth 2 composition))
- ch)
- (setcar composition
- (and (< from pos) (buffer-substring from pos)))
- (setcar (cdr composition)
- (and (< next to) (buffer-substring next to)))
- (dotimes (i (length components))
- (if (integerp (setq ch (aref components i)))
- (push (cons ch (describe-char-display pos ch))
- component-chars)))
- (setq component-chars (nreverse component-chars))
- (format "composed to form \"%s\" (see below)"
- (buffer-substring from to))))
- (t
- (let ((display (describe-char-display pos char)))
- (if (display-graphic-p (selected-frame))
- (if display
- (concat
- "by this font (glyph code)\n"
- (format " %s (0x%02X)"
- (car display) (cdr display)))
- "no font available")
+ (overlays (mapcar #'(lambda (o) (overlay-properties o))
+ (overlays-at pos)))
+ item-list max-width code)
+
+ (setq code (encode-char char charset))
+ (setq item-list
+ `(("character"
+ ,(format "%s (0%o, %d, 0x%x)"
+ (apply 'propertize (if (not multibyte-p)
+ (single-key-description char)
+ (if (< char 128)
+ (single-key-description char)
+ (string-to-multibyte
+ (char-to-string char))))
+ (text-properties-at pos))
+ char char char))
+ ("preferred charset"
+ ,(symbol-name charset)
+ ,(format "(%s)" (charset-description charset)))
+ ("code point"
+ ,(format (if (< code 256) "0x%02X" "0x%04X") code))
+ ("syntax"
+ ,(let ((syntax (syntax-after pos)))
+ (with-temp-buffer
+ (internal-describe-syntax-value syntax)
+ (buffer-string))))
+ ("category"
+ ,@(let ((category-set (char-category-set char)))
+ (if (not category-set)
+ '("-- none --")
+ (mapcar #'(lambda (x) (format "%c:%s "
+ x (category-docstring x)))
+ (category-set-mnemonics category-set)))))
+ ,@(let ((props (aref char-code-property-table char))
+ ps)
+ (when props
+ (while props
+ (push (format "%s:" (pop props)) ps)
+ (push (format "%s;" (pop props)) ps))
+ (list (cons "Properties" (nreverse ps)))))
+ ("to input"
+ ,@(let ((key-list (and current-input-method
+ (quail-find-key char))))
+ (if (consp key-list)
+ (list "type"
+ (mapconcat #'(lambda (x) (concat "\"" x "\""))
+ key-list " or ")))))
+ ("buffer code"
+ ,(encoded-string-description
+ (string-as-unibyte (char-to-string char)) nil))
+ ("file code"
+ ,@(let* ((coding buffer-file-coding-system)
+ (encoded (encode-coding-char char coding)))
+ (if encoded
+ (list (encoded-string-description encoded coding)
+ (format "(encoded by coding system %S)" coding))
+ (list "not encodable by coding system"
+ (symbol-name coding)))))
+ ("display"
+ ,(cond
+ (disp-vector
+ (setq disp-vector (copy-sequence disp-vector))
+ (dotimes (i (length disp-vector))
+ (setq char (aref disp-vector i))
+ (aset disp-vector i
+ (cons char (describe-char-display pos char))))
+ (format "by display table entry [%s] (see below)"
+ (mapconcat #'(lambda (x) (format "?%c" (car x)))
+ disp-vector " ")))
+ (composition
+ (let ((from (car composition))
+ (to (nth 1 composition))
+ (next (1+ pos))
+ (components (nth 2 composition))
+ ch)
+ (setcar composition
+ (and (< from pos) (buffer-substring from pos)))
+ (setcar (cdr composition)
+ (and (< next to) (buffer-substring next to)))
+ (dotimes (i (length components))
+ (if (integerp (setq ch (aref components i)))
+ (push (cons ch (describe-char-display pos ch))
+ component-chars)))
+ (setq component-chars (nreverse component-chars))
+ (format "composed to form \"%s\" (see below)"
+ (buffer-substring from to))))
+ (t
+ (let ((display (describe-char-display pos char)))
+ (if (display-graphic-p (selected-frame))
(if display
- (format "terminal code %s" display)
- "not encodable for terminal"))))))
- ,@(let ((unicodedata (unicode-data char)))
- (if unicodedata
- (cons (list "Unicode data" " ") unicodedata))))))
- (setq max-width (apply #'max (mapcar #'(lambda (x)
- (if (cadr x)
- (length (car x))
- 0))
+ (concat
+ "by this font (glyph code)\n"
+ (format " %s (0x%02X)"
+ (car display) (cdr display)))
+ "no font available")
+ (if display
+ (format "terminal code %s" display)
+ "not encodable for terminal"))))))
+ ,@(let ((unicodedata (describe-char-unicode-data char)))
+ (if unicodedata
+ (cons (list "Unicode data" " ") unicodedata)))))
+ (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
item-list)))
-
- (setq text-prop-description
- (with-temp-buffer
- (let ((buf (current-buffer)))
- (save-excursion
- (set-buffer buffer)
- (describe-text-properties pos buf)))
- (buffer-string)))
-
(with-output-to-temp-buffer "*Help*"
(with-current-buffer standard-output
(set-buffer-multibyte multibyte-p)
@@ -601,6 +594,18 @@ as well as widgets, buttons, overlays, and text properties."
(insert " " clm))
(insert "\n"))))
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "character:[ \t\n]+")
+ (setq pos (point)))
+ (if overlays
+ (mapc #'(lambda (props)
+ (let ((o (make-overlay pos (1+ pos))))
+ (while props
+ (overlay-put o (car props) (nth 1 props))
+ (setq props (cddr props)))))
+ overlays))
+
(when disp-vector
(insert
"\nThe display table entry is displayed by ")
@@ -622,7 +627,6 @@ as well as widgets, buttons, overlays, and text properties."
(or (cdr (aref disp-vector i)) "-- not encodable --")
"\n"))))
- (setq pos (point))
(when composition
(insert "\nComposed")
(if (car composition)
@@ -658,12 +662,10 @@ as well as widgets, buttons, overlays, and text properties."
(or (cdr elt) "-- not encodable --"))))
(insert "\nSee the variable `reference-point-alist' for "
"the meaning of the rule.\n"))
- (put-text-property pos (point) 'auto-composed t)
- (insert text-prop-description)
+ (describe-text-properties pos (current-buffer))
(describe-text-mode)))))
-
(defalias 'describe-char-after 'describe-char)
(make-obsolete 'describe-char-after 'describe-char "21.5")
diff --git a/lisp/desktop.el b/lisp/desktop.el
index 45f951883c6..a71fc6c79fe 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -83,12 +83,6 @@
;;; Code:
-;; Make the compilation more silent
-(eval-when-compile
- ;; We use functions from these modules
- ;; We can't (require 'mh-e) since that wants to load something.
- (mapcar 'require '(info dired reporter)))
-
(defvar desktop-file-version "206"
"Version number of desktop file format.
Written into the desktop file and used at desktop read to provide
@@ -151,8 +145,11 @@ The base name of the file is specified in `desktop-base-file-name'."
:group 'desktop)
(defcustom desktop-missing-file-warning nil
- "*If non-nil then `desktop-read' warns when a file no longer exists.
-Otherwise it simply ignores that file."
+ "*If non-nil then `desktop-read' asks if a non-existent file should be recreated.
+Also pause for a moment to display message about errors signaled in
+`desktop-buffer-mode-handlers'.
+
+If nil, just print error messages in the message buffer."
:type 'boolean
:group 'desktop)
@@ -250,14 +247,6 @@ The variables are saved only when they really are local."
:type 'regexp
:group 'desktop)
-(defcustom desktop-buffer-modes-to-save
- '(Info-mode rmail-mode)
- "If a buffer is of one of these major modes, save the buffer state.
-It is up to the functions in `desktop-buffer-handlers' to decide
-whether the buffer should be recreated or not, and how."
- :type '(repeat symbol)
- :group 'desktop)
-
(defcustom desktop-modes-not-to-save nil
"List of major modes whose buffers should not be saved."
:type '(repeat symbol)
@@ -272,53 +261,61 @@ Possible values are:
:type '(choice (const absolute) (const tilde) (const local))
:group 'desktop)
-(defcustom desktop-buffer-misc-functions
- '(desktop-buffer-info-misc-data
- desktop-buffer-dired-misc-data)
- "*Functions used to determine auxiliary information for a buffer.
-These functions are called by `desktop-save' in order, with no
-arguments. If a function returns non-nil, its value is saved along
-with the state of the buffer for which it was called; no further
-functions will be called.
+;;;###autoload
+(defvar desktop-save-buffer nil
+ "When non-nil, save buffer status in desktop file.
+This variable becomes buffer local when set.
+
+If the value is a function, it called by `desktop-save' with argument
+DESKTOP-DIRNAME to obtain auxiliary information to saved in the desktop
+file along with the state of the buffer for which it was called.
When file names are returned, they should be formatted using the call
-\"(desktop-file-name FILE-NAME dirname)\".
+\"(desktop-file-name FILE-NAME DESKTOP-DIRNAME)\".
-Later, when `desktop-read' restores buffers, each of the functions in
-`desktop-buffer-handlers' will have access to a buffer local variable,
-named `desktop-buffer-misc', whose value is what the function in
-`desktop-buffer-misc-functions' returned."
- :type '(repeat function)
- :group 'desktop)
+Later, when `desktop-read' calls a function in `desktop-buffer-mode-handlers'
+to restore the buffer, the auxiliary information is passed as the argument
+DESKTOP-BUFFER-MISC.")
+(make-variable-buffer-local 'desktop-save-buffer)
+(make-obsolete-variable 'desktop-buffer-modes-to-save
+ 'desktop-save-buffer)
+(make-obsolete-variable 'desktop-buffer-misc-functions
+ 'desktop-save-buffer)
-(defcustom desktop-buffer-handlers
- '(desktop-buffer-dired
- desktop-buffer-rmail
- desktop-buffer-mh
- desktop-buffer-info
- desktop-buffer-file)
- "*Functions called by `desktop-read' in order to create a buffer.
-The functions are called without explicit parameters but can use the
-following variables:
+(defcustom desktop-buffer-mode-handlers '(
+ (dired-mode . dired-restore-desktop-buffer)
+ (rmail-mode . rmail-restore-desktop-buffer)
+ (mh-folder-mode . mh-restore-desktop-buffer)
+ (Info-mode . Info-restore-desktop-buffer))
+ "Alist of major mode specific functions to restore a desktop buffer.
+Functions are called by `desktop-read'. List elements must have the form
+\(MAJOR-MODE . RESTORE-BUFFER-FUNCTION).
+
+Buffers with a major mode not specified here, are restored by the default
+handler `desktop-restore-file-buffer'.
+
+Handlers are called with argument list
+
+ (DESKTOP-BUFFER-FILE-NAME DESKTOP-BUFFER-NAME DESKTOP-BUFFER-MISC)
+
+Furthermore, they may use the following variables:
desktop-file-version
- desktop-buffer-file-name
- desktop-buffer-name
desktop-buffer-major-mode
desktop-buffer-minor-modes
desktop-buffer-point
desktop-buffer-mark
desktop-buffer-read-only
- desktop-buffer-misc
desktop-buffer-locals
-If one function returns non-nil, no further functions are called.
-If the function returns a buffer, then the saved mode settings
+If a handler returns a buffer, then the saved mode settings
and variable values for that buffer are copied into it."
- :type '(repeat function)
+ :type 'alist
:group 'desktop)
-(put 'desktop-buffer-handlers 'risky-local-variable t)
+(put 'desktop-buffer-mode-handlers 'risky-local-variable t)
+(make-obsolete-variable 'desktop-buffer-handlers
+ 'desktop-buffer-mode-handlers)
(defcustom desktop-minor-mode-table
'((auto-fill-function auto-fill-mode)
@@ -329,7 +326,7 @@ NAME is the name of the buffer-local variable indicating that the minor
mode is active. RESTORE-FUNCTION is the function to activate the minor mode.
called. RESTORE-FUNCTION nil means don't try to restore the minor mode.
Only minor modes for which the name of the buffer-local variable
-and the name of the minor mode function are different have to added to
+and the name of the minor mode function are different have to be added to
this table."
:type 'sexp
:group 'desktop)
@@ -540,21 +537,20 @@ which means to truncate VAR's value to at most MAX-SIZE elements
;; ----------------------------------------------------------------------------
(defun desktop-save-buffer-p (filename bufname mode &rest dummy)
- "Return t if the desktop should record a particular buffer for next startup.
+ "Return t if buffer should have its state saved in the desktop file.
FILENAME is the visited file name, BUFNAME is the buffer name, and
MODE is the major mode."
(let ((case-fold-search nil))
(and (not (string-match desktop-buffers-not-to-save bufname))
- (not (memq mode desktop-modes-not-to-save))
- (or (and filename
- (not (string-match desktop-files-not-to-save filename)))
- (and (eq mode 'dired-mode)
- (save-excursion
- (set-buffer (get-buffer bufname))
- (not (string-match desktop-files-not-to-save
- default-directory))))
- (and (null filename)
- (memq mode desktop-buffer-modes-to-save))))))
+ (not (memq mode desktop-modes-not-to-save))
+ (or (and filename
+ (not (string-match desktop-files-not-to-save filename)))
+ (and (eq mode 'dired-mode)
+ (with-current-buffer bufname
+ (not (string-match desktop-files-not-to-save
+ default-directory))))
+ (and (null filename)
+ (with-current-buffer bufname desktop-save-buffer))))))
;; ----------------------------------------------------------------------------
(defun desktop-file-name (filename dirname)
@@ -593,22 +589,25 @@ See also `desktop-base-file-name'."
major-mode
;; minor modes
(let (ret)
- (mapcar
- #'(lambda (mim)
+ (mapc
+ #'(lambda (minor-mode)
(and
- (boundp mim)
- (symbol-value mim)
- (setq ret
- (cons
- (let ((special (assq mim desktop-minor-mode-table)))
- (if special (cadr special) mim))
- ret))))
+ (boundp minor-mode)
+ (symbol-value minor-mode)
+ (let ((special (assq minor-mode desktop-minor-mode-table)))
+ (when (or special (functionp minor-mode))
+ (setq ret
+ (cons
+ (if special (cadr special) minor-mode)
+ ret))))))
(mapcar #'car minor-mode-alist))
ret)
(point)
(list (mark t) mark-active)
buffer-read-only
- (run-hook-with-args-until-success 'desktop-buffer-misc-functions)
+ ;; Auxiliary information
+ (when (functionp desktop-save-buffer)
+ (funcall desktop-save-buffer dirname))
(let ((locals desktop-locals-to-save)
(loclist (buffer-local-variables))
(ll))
@@ -703,7 +702,9 @@ It returns t if a desktop file was loaded, nil otherwise."
"~"))))
(if (file-exists-p (expand-file-name desktop-base-file-name desktop-dirname))
;; Desktop file found, process it.
- (let ((desktop-first-buffer nil))
+ (let ((desktop-first-buffer nil)
+ (desktop-buffer-ok-count 0)
+ (desktop-buffer-fail-count 0))
;; Evaluate desktop buffer.
(load (expand-file-name desktop-base-file-name desktop-dirname) t t t)
;; `desktop-create-buffer' puts buffers at end of the buffer list.
@@ -715,7 +716,12 @@ It returns t if a desktop file was loaded, nil otherwise."
(run-hooks 'desktop-delay-hook)
(setq desktop-delay-hook nil)
(run-hooks 'desktop-after-read-hook)
- (message "Desktop loaded.")
+ (message "Desktop: %d buffer%s restored%s."
+ desktop-buffer-ok-count
+ (if (= 1 desktop-buffer-ok-count) "" "s")
+ (if (< 0 desktop-buffer-fail-count)
+ (format ", %d failed to restore" desktop-buffer-fail-count)
+ ""))
t)
;; No desktop file found.
(desktop-clear)
@@ -772,106 +778,21 @@ directory DIRNAME."
(desktop-read desktop-dirname))
;; ----------------------------------------------------------------------------
-;; Note: the following functions use the dynamic variable binding in Lisp.
-;;
-
-(eval-when-compile ; Just to silence the byte compiler
- (defvar desktop-file-version)
- (defvar desktop-buffer-file-name)
- (defvar desktop-buffer-name)
- (defvar desktop-buffer-major-mode)
- (defvar desktop-buffer-minor-modes)
- (defvar desktop-buffer-point)
- (defvar desktop-buffer-mark)
- (defvar desktop-buffer-read-only)
- (defvar desktop-buffer-misc)
- (defvar desktop-buffer-locals)
-)
-
-(defun desktop-buffer-info-misc-data ()
- (if (eq major-mode 'Info-mode)
- (list Info-current-file
- Info-current-node)))
-
-;; ----------------------------------------------------------------------------
-(defun desktop-buffer-dired-misc-data ()
- (when (eq major-mode 'dired-mode)
- (eval-when-compile (defvar dirname))
- (cons
- ;; Value of `dired-directory'.
- (if (consp dired-directory)
- ;; Directory name followed by list of files.
- (cons (desktop-file-name (car dired-directory) dirname) (cdr dired-directory))
- ;; Directory name, optionally with with shell wildcard.
- (desktop-file-name dired-directory dirname))
- ;; Subdirectories in `dired-subdir-alist'.
- (cdr
- (nreverse
- (mapcar
- (function (lambda (f) (desktop-file-name (car f) dirname)))
- dired-subdir-alist))))))
-
-;; ----------------------------------------------------------------------------
-(defun desktop-buffer-info () "Load an info file."
- (if (eq 'Info-mode desktop-buffer-major-mode)
- (progn
- (let ((first (nth 0 desktop-buffer-misc))
- (second (nth 1 desktop-buffer-misc)))
- (when (and first second)
- (require 'info)
- (with-no-warnings
- (Info-find-node first second))
- (current-buffer))))))
-
-;; ----------------------------------------------------------------------------
-(eval-when-compile (defvar rmail-buffer)) ; Just to silence the byte compiler.
-(defun desktop-buffer-rmail () "Load an RMAIL file."
- (if (eq 'rmail-mode desktop-buffer-major-mode)
- (condition-case error
- (progn (rmail-input desktop-buffer-file-name)
- (if (eq major-mode 'rmail-mode)
- (current-buffer)
- rmail-buffer))
- (file-locked
- (kill-buffer (current-buffer))
- 'ignored))))
-
-;; ----------------------------------------------------------------------------
-(defun desktop-buffer-mh () "Load a folder in the mh system."
- (if (eq 'mh-folder-mode desktop-buffer-major-mode)
- (with-no-warnings
- (mh-find-path)
- (mh-visit-folder desktop-buffer-name)
- (current-buffer))))
-
-;; ----------------------------------------------------------------------------
-(defun desktop-buffer-dired () "Load a directory using dired."
- (if (eq 'dired-mode desktop-buffer-major-mode)
- ;; First element of `desktop-buffer-misc' is the value of `dired-directory'.
- ;; This value is a directory name, optionally with with shell wildcard or
- ;; a directory name followed by list of files.
- (let* ((dired-dir (car desktop-buffer-misc))
- (dir (if (consp dired-dir) (car dired-dir) dired-dir)))
- (if (file-directory-p (file-name-directory dir))
- (progn
- (dired dired-dir)
- ;; The following elements of `desktop-buffer-misc' are the keys
- ;; from `dired-subdir-alist'.
- (mapcar 'dired-maybe-insert-subdir (cdr desktop-buffer-misc))
- (current-buffer))
- (message "Directory %s no longer exists." dir)
- (sit-for 1)
- 'ignored))))
-
-;; ----------------------------------------------------------------------------
-(defun desktop-buffer-file ()
- "Load a file."
+(defun desktop-restore-file-buffer (desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ "Restore a file buffer."
+ (eval-when-compile ; Just to silence the byte compiler
+ (defvar desktop-buffer-major-mode)
+ (defvar desktop-buffer-locals))
(if desktop-buffer-file-name
(if (or (file-exists-p desktop-buffer-file-name)
- (and desktop-missing-file-warning
- (y-or-n-p (format
- "File \"%s\" no longer exists. Re-create? "
- desktop-buffer-file-name))))
+ (let ((msg (format "Desktop: File \"%s\" no longer exists."
+ desktop-buffer-file-name)))
+ (if desktop-missing-file-warning
+ (y-or-n-p (concat msg " Re-create? "))
+ (message msg)
+ nil)))
(let* ((auto-insert nil) ; Disable auto insertion
(coding-system-for-read
(or coding-system-for-read
@@ -885,11 +806,11 @@ directory DIRNAME."
(functionp desktop-buffer-major-mode)
(funcall desktop-buffer-major-mode))
buf)
- 'ignored)))
+ nil)))
;; ----------------------------------------------------------------------------
-;; Create a buffer, load its file, set is mode, ...; called from Desktop file
-;; only.
+;; Create a buffer, load its file, set its mode, ...;
+;; called from Desktop file only.
(eval-when-compile ; Just to silence the byte compiler
(defvar desktop-first-buffer) ;; Dynamically bound in `desktop-read'
@@ -907,20 +828,32 @@ directory DIRNAME."
desktop-buffer-misc
&optional
desktop-buffer-locals)
+ ;; Just to silence the byte compiler. Bound locally in `desktop-read'.
+ (eval-when-compile
+ (defvar desktop-buffer-ok-count)
+ (defvar desktop-buffer-fail-count))
;; To make desktop files with relative file names possible, we cannot
;; allow `default-directory' to change. Therefore we save current buffer.
(save-current-buffer
(let (
(buffer-list (buffer-list))
- (hlist desktop-buffer-handlers)
- (result)
- (handler)
+ (result
+ (condition-case err
+ (funcall (or (cdr (assq desktop-buffer-major-mode desktop-buffer-mode-handlers))
+ 'desktop-restore-file-buffer)
+ desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ (error
+ (message "Desktop: Can't load buffer %s: %s"
+ desktop-buffer-name (error-message-string err))
+ (when desktop-missing-file-warning (sit-for 1))
+ nil)))
)
- ;; Call desktop-buffer-handlers to create buffer.
- (while (and (not result) hlist)
- (setq handler (car hlist))
- (setq result (funcall handler))
- (setq hlist (cdr hlist)))
+ (if (bufferp result)
+ (setq desktop-buffer-ok-count (1+ desktop-buffer-ok-count))
+ (setq desktop-buffer-fail-count (1+ desktop-buffer-fail-count))
+ (setq result nil))
(unless (bufferp result) (setq result nil))
;; Restore buffer list order with new buffer at end. Don't change
;; the order for old desktop files (old desktop module behaviour).
@@ -947,7 +880,12 @@ directory DIRNAME."
desktop-buffer-minor-modes)))
;; Even though point and mark are non-nil when written by `desktop-save'
;; they may be modified by handlers wanting to set point or mark themselves.
- (when desktop-buffer-point (goto-char desktop-buffer-point))
+ (when desktop-buffer-point
+ (goto-char
+ (condition-case err
+ ;; Evaluate point. Thus point can be something like '(search-forward ...
+ (eval desktop-buffer-point)
+ (error (message "%s" (error-message-string err)) 1))))
(when desktop-buffer-mark
(if (consp desktop-buffer-mark)
(progn
diff --git a/lisp/diff-mode.el b/lisp/diff-mode.el
index f6b2520a112..26ff5441baf 100644
--- a/lisp/diff-mode.el
+++ b/lisp/diff-mode.el
@@ -48,7 +48,6 @@
;;
;; - Refine hunk on a word-by-word basis.
;;
-;; - Use the new next-error-function to allow C-x `.
;; - Handle `diff -b' output in context->unified.
;;; Code:
@@ -170,27 +169,27 @@ when editing big diffs)."
;;;;
(defface diff-header-face
- '((((type tty pc) (class color) (background light))
- (:foreground "blue1" :weight bold))
- (((type tty pc) (class color) (background dark))
- (:foreground "green" :weight bold))
- (((class color) (background light))
+ '((((class color) (min-colors 88) (background light))
(:background "grey85"))
- (((class color) (background dark))
+ (((class color) (min-colors 88) (background dark))
(:background "grey45"))
+ (((class color) (background light))
+ (:foreground "blue1" :weight bold))
+ (((class color) (background dark))
+ (:foreground "green" :weight bold))
(t (:weight bold)))
"`diff-mode' face inherited by hunk and index header faces.")
(defvar diff-header-face 'diff-header-face)
(defface diff-file-header-face
- '((((type tty pc) (class color) (background light))
- (:foreground "yellow" :weight bold))
- (((type tty pc) (class color) (background dark))
- (:foreground "cyan" :weight bold))
- (((class color) (background light))
+ '((((class color) (min-colors 88) (background light))
(:background "grey70" :weight bold))
- (((class color) (background dark))
+ (((class color) (min-colors 88) (background dark))
(:background "grey60" :weight bold))
+ (((class color) (background light))
+ (:foreground "yellow" :weight bold))
+ (((class color) (background dark))
+ (:foreground "cyan" :weight bold))
(t (:weight bold))) ; :height 1.3
"`diff-mode' face used to highlight file header lines.")
(defvar diff-file-header-face 'diff-file-header-face)
@@ -305,7 +304,11 @@ when editing big diffs)."
(defvar diff-narrowed-to nil)
(defun diff-end-of-hunk (&optional style)
- (if (looking-at diff-hunk-header-re) (goto-char (match-end 0)))
+ (when (looking-at diff-hunk-header-re)
+ (unless style
+ ;; Especially important for unified (because headers are ambiguous).
+ (setq style (cdr (assq (char-after) '((?@ . unified) (?* . context))))))
+ (goto-char (match-end 0)))
(let ((end (and (re-search-forward (case style
;; A `unified' header is ambiguous.
(unified (concat "^[^-+# \\]\\|"
@@ -882,9 +885,14 @@ See `after-change-functions' for the meaning of BEG, END and LEN."
(diff-fixup-modifs (point) (cdr diff-unhandled-changes)))))
(setq diff-unhandled-changes nil)))
-;;;;
-;;;; The main function
-;;;;
+(defun diff-next-error (arg reset)
+ ;; Select a window that displays the current buffer so that point
+ ;; movements are reflected in that window. Otherwise, the user might
+ ;; never see the hunk corresponding to the source she's jumping to.
+ (pop-to-buffer (current-buffer))
+ (if reset (goto-char (point-min)))
+ (diff-hunk-next arg)
+ (diff-goto-source))
;;;###autoload
(define-derived-mode diff-mode fundamental-mode "Diff"
@@ -912,6 +920,7 @@ a diff with \\[diff-reverse-direction]."
;; (set (make-local-variable 'paragraph-separate) paragraph-start)
;; (set (make-local-variable 'page-delimiter) "--- [^\t]+\t")
;; compile support
+ (set (make-local-variable 'next-error-function) 'diff-next-error)
(when (and (> (point-max) (point-min)) diff-default-read-only)
(toggle-read-only t))
@@ -967,7 +976,7 @@ a diff with \\[diff-reverse-direction]."
"Turn context diffs into unified diffs if applicable."
(if (save-excursion
(goto-char (point-min))
- (looking-at "\\*\\*\\* "))
+ (and (looking-at diff-hunk-header-re) (eq (char-after) ?*)))
(let ((mod (buffer-modified-p)))
(unwind-protect
(diff-context->unified (point-min) (point-max))
@@ -1239,9 +1248,12 @@ If the prefix arg is bigger than 8 (for example with \\[universal-argument] \\[u
(defun diff-current-defun ()
"Find the name of function at point.
For use in `add-log-current-defun-function'."
- (destructuring-bind (buf line-offset pos src dst &optional switched)
- (diff-find-source-location)
- (save-excursion
+ (save-excursion
+ (when (looking-at diff-hunk-header-re)
+ (forward-line 1)
+ (while (and (looking-at " ") (not (zerop (forward-line 1))))))
+ (destructuring-bind (buf line-offset pos src dst &optional switched)
+ (diff-find-source-location)
(beginning-of-line)
(or (when (memq (char-after) '(?< ?-))
;; Cursor is pointing at removed text. This could be a removed
diff --git a/lisp/diff.el b/lisp/diff.el
index 231130db212..c985b66036e 100644
--- a/lisp/diff.el
+++ b/lisp/diff.el
@@ -36,7 +36,7 @@
;;;###autoload
(defcustom diff-switches "-c"
- "*A string or list of strings specifying switches to be be passed to diff."
+ "*A string or list of strings specifying switches to be passed to diff."
:type '(choice string (repeat string))
:group 'diff)
@@ -111,6 +111,7 @@ With prefix arg, prompt for diff switches."
,(shell-quote-argument (or new-alt new)))
" "))
(buf (get-buffer-create "*Diff*"))
+ (thisdir default-directory)
proc)
(save-excursion
(display-buffer buf)
@@ -125,6 +126,7 @@ With prefix arg, prompt for diff switches."
(diff ',old ',new ',switches ',no-async)))
(set (make-local-variable 'diff-old-temp-file) old-alt)
(set (make-local-variable 'diff-new-temp-file) new-alt)
+ (setq default-directory thisdir)
(insert command "\n")
(if (and (not no-async) (fboundp 'start-process))
(progn
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 0709e0cfe1c..bf7c9c00d18 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -64,7 +64,10 @@ With prefix arg, prompt for second argument SWITCHES,
(if default
(concat "(default " default ") ")
""))
- (dired-current-directory) default t)
+ (if default
+ (dired-current-directory)
+ (dired-dwim-target-directory))
+ default t)
(if current-prefix-arg
(read-string "Options for diff: "
(if (stringp diff-switches)
@@ -185,6 +188,18 @@ List has a form of (file-name full-file-name (attribute-list))"
(file-attributes full-file-name))))
(directory-files dir)))
+
+(defun dired-touch-initial (files)
+ "Create initial input value for `touch' command."
+ (let (initial)
+ (while files
+ (let ((current (nth 5 (file-attributes (car files)))))
+ (if (and initial (not (equal initial current)))
+ (setq initial (current-time) files nil)
+ (setq initial current))
+ (setq files (cdr files))))
+ (format-time-string "%Y%m%d%H%M.%S" initial)))
+
(defun dired-do-chxxx (attribute-name program op-symbol arg)
;; Change file attributes (mode, group, owner, timestamp) of marked files and
;; refresh their file lines.
@@ -196,7 +211,8 @@ List has a form of (file-name full-file-name (attribute-list))"
(new-attribute
(dired-mark-read-string
(concat "Change " attribute-name " of %s to: ")
- nil op-symbol arg files))
+ (if (eq op-symbol 'touch) (dired-touch-initial files))
+ op-symbol arg files))
(operation (concat program " " new-attribute))
failures)
(setq failures
@@ -239,6 +255,7 @@ This calls chmod, thus symbolic modes like `g+w' are allowed."
(error "chown not supported on this system"))
(dired-do-chxxx "Owner" dired-chown-program 'chown arg))
+;;;###autoload
(defun dired-do-touch (&optional arg)
"Change the timestamp of the marked (or next ARG) files.
This calls touch."
@@ -326,6 +343,7 @@ Uses the shell command coming from variables `lpr-command' and
(defvar dired-file-version-alist)
+;;;###autoload
(defun dired-clean-directory (keep)
"Flag numerical backups for deletion.
Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
@@ -535,6 +553,7 @@ the list of file names explicitly with the FILE-LIST argument."
(funcall stuff-it files)))))
;; This is an extra function so that it can be redefined by ange-ftp.
+;;;###autoload
(defun dired-run-shell-command (command)
(let ((handler
(find-file-name-handler (directory-file-name default-directory)
@@ -789,6 +808,7 @@ Otherwise, the rule is a compression rule, and compression is done with gzip.")
;; None of these keys quit - use C-g for that.
))
+;;;###autoload
(defun dired-query (qs-var qs-prompt &rest qs-args)
;; Query user and return nil or t.
;; Store answer in symbol VAR (which must initially be bound to nil).
@@ -875,13 +895,27 @@ Otherwise, the rule is a compression rule, and compression is done with gzip.")
(defun dired-do-redisplay (&optional arg test-for-subdir)
"Redisplay all marked (or next ARG) files.
If on a subdir line, redisplay that subdirectory. In that case,
-a prefix arg lets you edit the `ls' switches used for the new listing."
+a prefix arg lets you edit the `ls' switches used for the new listing.
+
+Dired remembers switches specified with a prefix arg, so that reverting
+the buffer will not reset them. However, using `dired-undo' to re-insert
+or delete subdirectories can bypass this machinery. Hence, you sometimes
+may have to reset some subdirectory switches after a `dired-undo'.
+You can reset all subdirectory switches to the default using
+\\<dired-mode-map>\\[dired-reset-subdir-switches].
+See Info node `(emacs-xtra)Subdir switches' for more details."
;; Moves point if the next ARG files are redisplayed.
(interactive "P\np")
(if (and test-for-subdir (dired-get-subdir))
- (dired-insert-subdir
- (dired-get-subdir)
- (if arg (read-string "Switches for listing: " dired-actual-switches)))
+ (let* ((dir (dired-get-subdir))
+ (switches (cdr (assoc-string dir dired-switches-alist))))
+ (dired-insert-subdir
+ dir
+ (when arg
+ (read-string "Switches for listing: "
+ (or switches
+ dired-subdir-switches
+ dired-actual-switches)))))
(message "Redisplaying...")
;; message much faster than making dired-map-over-marks show progress
(dired-uncache
@@ -892,6 +926,12 @@ a prefix arg lets you edit the `ls' switches used for the new listing."
arg)
(dired-move-to-filename)
(message "Redisplaying...done")))
+
+(defun dired-reset-subdir-switches ()
+ "Set `dired-switches-alist' to nil and revert dired buffer."
+ (interactive)
+ (setq dired-switches-alist nil)
+ (revert-buffer))
(defun dired-update-file-line (file)
;; Delete the current line, and insert an entry for FILE.
@@ -1191,9 +1231,10 @@ Special value `always' suppresses confirmation."
(dired-advertise)))))
(defun dired-rename-subdir-2 (elt dir to)
- ;; Update the headerline and dired-subdir-alist element of directory
- ;; described by alist-element ELT to reflect the moving of DIR to TO.
- ;; Thus, ELT describes either DIR itself or a subdir of DIR.
+ ;; Update the headerline and dired-subdir-alist element, as well as
+ ;; dired-switches-alist element, of directory described by
+ ;; alist-element ELT to reflect the moving of DIR to TO. Thus, ELT
+ ;; describes either DIR itself or a subdir of DIR.
(save-excursion
(let ((regexp (regexp-quote (directory-file-name dir)))
(newtext (directory-file-name to))
@@ -1207,10 +1248,12 @@ Special value `always' suppresses confirmation."
(if (re-search-forward regexp (match-end 1) t)
(replace-match newtext t t)
(error "Expected to find `%s' in headerline of %s" dir (car elt))))
- ;; Update buffer-local dired-subdir-alist
- (setcar elt
- (dired-normalize-subdir
- (dired-replace-in-string regexp newtext (car elt)))))))
+ ;; Update buffer-local dired-subdir-alist and dired-switches-alist
+ (let ((cons (assoc-string (car elt) dired-switches-alist))
+ (cur-dir (dired-normalize-subdir
+ (dired-replace-in-string regexp newtext (car elt)))))
+ (setcar elt cur-dir)
+ (when cons (setcar cons cur-dir))))))
;; The basic function for half a dozen variations on cp/mv/ln/ln -s.
(defun dired-create-files (file-creator operation fn-list name-constructor
@@ -1702,11 +1745,20 @@ If it is already present, just move to it (type \\[dired-do-redisplay] to refres
With a prefix arg, you may edit the ls switches used for this listing.
You can add `R' to the switches to expand the whole tree starting at
this subdirectory.
-This function takes some pains to conform to `ls -lR' output."
+This function takes some pains to conform to `ls -lR' output.
+
+Dired remembers switches specified with a prefix arg, so that reverting
+the buffer will not reset them. However, using `dired-undo' to re-insert
+or delete subdirectories can bypass this machinery. Hence, you sometimes
+may have to reset some subdirectory switches after a `dired-undo'.
+You can reset all subdirectory switches to the default using
+\\<dired-mode-map>\\[dired-reset-subdir-switches].
+See Info node `(emacs-xtra)Subdir switches' for more details."
(interactive
(list (dired-get-filename)
(if current-prefix-arg
- (read-string "Switches for listing: " dired-actual-switches))))
+ (read-string "Switches for listing: "
+ (or dired-subdir-switches dired-actual-switches)))))
(let ((opoint (point)))
;; We don't need a marker for opoint as the subdir is always
;; inserted *after* opoint.
@@ -1733,14 +1785,19 @@ This function takes some pains to conform to `ls -lR' output."
(interactive
(list (dired-get-filename)
(if current-prefix-arg
- (read-string "Switches for listing: " dired-actual-switches))))
+ (read-string "Switches for listing: "
+ (or dired-subdir-switches dired-actual-switches)))))
(setq dirname (file-name-as-directory (expand-file-name dirname)))
- (dired-insert-subdir-validate dirname switches)
(or no-error-if-not-dir-p
(file-directory-p dirname)
(error "Attempt to insert a non-directory: %s" dirname))
(let ((elt (assoc dirname dired-subdir-alist))
- switches-have-R mark-alist case-fold-search buffer-read-only)
+ (cons (assoc-string dirname dired-switches-alist))
+ (modflag (buffer-modified-p))
+ (old-switches switches)
+ switches-have-R mark-alist case-fold-search buffer-read-only)
+ (and (not switches) cons (setq switches (cdr cons)))
+ (dired-insert-subdir-validate dirname switches)
;; case-fold-search is nil now, so we can test for capital `R':
(if (setq switches-have-R (and switches (string-match "R" switches)))
;; avoid duplicated subdirs
@@ -1751,9 +1808,23 @@ This function takes some pains to conform to `ls -lR' output."
(dired-insert-subdir-newpos dirname)) ; else compute new position
(dired-insert-subdir-doupdate
dirname elt (dired-insert-subdir-doinsert dirname switches))
- (if switches-have-R (dired-build-subdir-alist switches))
+ (when old-switches
+ (if cons
+ (setcdr cons switches)
+ (push (cons dirname switches) dired-switches-alist)))
+ (when switches-have-R
+ (dired-build-subdir-alist switches)
+ (setq switches (dired-replace-in-string "R" "" switches))
+ (dolist (cur-ass dired-subdir-alist)
+ (let ((cur-dir (car cur-ass)))
+ (and (dired-in-this-tree cur-dir dirname)
+ (let ((cur-cons (assoc-string cur-dir dired-switches-alist)))
+ (if cur-cons
+ (setcdr cur-cons switches)
+ (push (cons cur-dir switches) dired-switches-alist)))))))
(dired-initial-position dirname)
- (save-excursion (dired-mark-remembered mark-alist))))
+ (save-excursion (dired-mark-remembered mark-alist))
+ (restore-buffer-modified-p modflag)))
;; This is a separate function for dired-vms.
(defun dired-insert-subdir-validate (dirname &optional switches)
@@ -1761,17 +1832,18 @@ This function takes some pains to conform to `ls -lR' output."
;; Signal an error if invalid (e.g. user typed `i' on `..').
(or (dired-in-this-tree dirname (expand-file-name default-directory))
(error "%s: not in this directory tree" dirname))
- (if switches
+ (let ((real-switches (or switches dired-subdir-switches)))
+ (when real-switches
(let (case-fold-search)
(mapcar
(function
(lambda (x)
- (or (eq (null (string-match x switches))
+ (or (eq (null (string-match x real-switches))
(null (string-match x dired-actual-switches)))
- (error "Can't have dirs with and without -%s switches together"
- x))))
+ (error
+ "Can't have dirs with and without -%s switches together" x))))
;; all switches that make a difference to dired-get-filename:
- '("F" "b")))))
+ '("F" "b"))))))
(defun dired-alist-add (dir new-marker)
;; Add new DIR at NEW-MARKER. Sort alist.
@@ -1786,19 +1858,23 @@ This function takes some pains to conform to `ls -lR' output."
(> (dired-get-subdir-min elt1)
(dired-get-subdir-min elt2)))))))
-(defun dired-kill-tree (dirname &optional remember-marks)
+(defun dired-kill-tree (dirname &optional remember-marks kill-root)
"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself.
-With optional arg REMEMBER-MARKS, return an alist of marked files."
- (interactive "DKill tree below directory: ")
- (setq dirname (expand-file-name dirname))
+Interactively, you can kill DIRNAME as well by using a prefix argument.
+In interactive use, the command prompts for DIRNAME.
+
+When called from Lisp, if REMEMBER-MARKS is non-nil, return an alist
+of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well."
+ (interactive "DKill tree below directory: \ni\nP")
+ (setq dirname (file-name-as-directory (expand-file-name dirname)))
(let ((s-alist dired-subdir-alist) dir m-alist)
(while s-alist
(setq dir (car (car s-alist))
s-alist (cdr s-alist))
- (if (and (not (string-equal dir dirname))
- (dired-in-this-tree dir dirname)
- (dired-goto-subdir dir))
- (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
+ (and (or kill-root (not (string-equal dir dirname)))
+ (dired-in-this-tree dir dirname)
+ (dired-goto-subdir dir)
+ (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist))))
m-alist))
(defun dired-insert-subdir-newpos (new-dir)
@@ -1839,16 +1915,15 @@ With optional arg REMEMBER-MARKS, return an alist of marked files."
;; Return the boundary of the inserted text (as list of BEG and END).
(save-excursion
(let ((begin (point)))
- (message "Reading directory %s..." dirname)
(let ((dired-actual-switches
(or switches
+ dired-subdir-switches
(dired-replace-in-string "R" "" dired-actual-switches))))
(if (equal dirname (car (car (last dired-subdir-alist))))
;; If doing the top level directory of the buffer,
;; redo it as specified in dired-directory.
(dired-readin-insert)
(dired-insert-directory dirname dired-actual-switches nil nil t)))
- (message "Reading directory %s...done" dirname)
(list begin (point)))))
(defun dired-insert-subdir-doupdate (dirname elt beg-end)
@@ -1991,10 +2066,12 @@ marks the files listed in the subdirectory that point is in."
Lower levels are unaffected."
;; With optional REMEMBER-MARKS, return a mark-alist.
(interactive)
- (let ((beg (dired-subdir-min))
- (end (dired-subdir-max))
- buffer-read-only cur-dir)
- (setq cur-dir (dired-current-directory))
+ (let* ((beg (dired-subdir-min))
+ (end (dired-subdir-max))
+ (modflag (buffer-modified-p))
+ (cur-dir (dired-current-directory))
+ (cons (assoc-string cur-dir dired-switches-alist))
+ buffer-read-only)
(if (equal cur-dir default-directory)
(error "Attempt to kill top level directory"))
(prog1
@@ -2002,7 +2079,10 @@ Lower levels are unaffected."
(delete-region beg end)
(if (eobp) ; don't leave final blank line
(delete-char -1))
- (dired-unsubdir cur-dir))))
+ (dired-unsubdir cur-dir)
+ (when cons
+ (setq dired-switches-alist (delete cons dired-switches-alist)))
+ (restore-buffer-modified-p modflag))))
(defun dired-unsubdir (dir)
;; Remove DIR from the alist
@@ -2061,19 +2141,21 @@ Optional prefix arg is a repeat factor.
Use \\[dired-hide-all] to (un)hide all directories."
(interactive "p")
(dired-hide-check)
- (while (>= (setq arg (1- arg)) 0)
- (let* ((cur-dir (dired-current-directory))
- (hidden-p (dired-subdir-hidden-p cur-dir))
- (elt (assoc cur-dir dired-subdir-alist))
- (end-pos (1- (dired-get-subdir-max elt)))
- buffer-read-only)
- ;; keep header line visible, hide rest
- (goto-char (dired-get-subdir-min elt))
- (skip-chars-forward "^\n\r")
- (if hidden-p
- (subst-char-in-region (point) end-pos ?\r ?\n)
- (subst-char-in-region (point) end-pos ?\n ?\r)))
- (dired-next-subdir 1 t)))
+ (let ((modflag (buffer-modified-p)))
+ (while (>= (setq arg (1- arg)) 0)
+ (let* ((cur-dir (dired-current-directory))
+ (hidden-p (dired-subdir-hidden-p cur-dir))
+ (elt (assoc cur-dir dired-subdir-alist))
+ (end-pos (1- (dired-get-subdir-max elt)))
+ buffer-read-only)
+ ;; keep header line visible, hide rest
+ (goto-char (dired-get-subdir-min elt))
+ (skip-chars-forward "^\n\r")
+ (if hidden-p
+ (subst-char-in-region (point) end-pos ?\r ?\n)
+ (subst-char-in-region (point) end-pos ?\n ?\r)))
+ (dired-next-subdir 1 t))
+ (restore-buffer-modified-p modflag)))
;;;###autoload
(defun dired-hide-all (arg)
@@ -2082,7 +2164,8 @@ If there is already something hidden, make everything visible again.
Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
(interactive "P")
(dired-hide-check)
- (let (buffer-read-only)
+ (let ((modflag (buffer-modified-p))
+ buffer-read-only)
(if (save-excursion
(goto-char (point-min))
(search-forward "\r" nil t))
@@ -2091,7 +2174,7 @@ Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
;; hide
(let ((pos (point-max)) ; pos of end of last directory
(alist dired-subdir-alist))
- (while alist ; while there are dirs before pos
+ (while alist ; while there are dirs before pos
(subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir
(save-excursion
(goto-char pos) ; current dir
@@ -2100,7 +2183,8 @@ Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
(point))
?\n ?\r)
(setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir
- (setq alist (cdr alist)))))))
+ (setq alist (cdr alist)))))
+ (restore-buffer-modified-p modflag)))
;;;###end dired-ins.el
diff --git a/lisp/dired-x.el b/lisp/dired-x.el
index 21fe4902e58..6b44b73b170 100644
--- a/lisp/dired-x.el
+++ b/lisp/dired-x.el
@@ -50,7 +50,7 @@
;; (add-hook 'dired-mode-hook
;; (function (lambda ()
;; ;; Set buffer-local variables here. For example:
-;; ;; (setq dired-omit-files-p t)
+;; ;; (dired-omit-mode 1)
;; )))
;;
;; At load time dired-x.el will install itself, redefine some functions, and
@@ -74,7 +74,7 @@
;; dired-guess-shell-znew-switches
;; dired-guess-shell-alist-user
;; dired-clean-up-buffers-too
-;; dired-omit-files-p
+;; dired-omit-mode
;; dired-omit-files
;; dired-omit-extensions
;; dired-omit-size-limit
@@ -154,19 +154,27 @@ Read-only folders only work in VM 5, not in VM 4."
(other :tag "non-writable only" if-file-read-only))
:group 'dired-x)
-(defcustom dired-omit-files-p nil
- "*If non-nil, \"uninteresting\" files are not listed (buffer-local).
-Use \\[dired-omit-toggle] to toggle its value.
+(define-minor-mode dired-omit-mode
+ "Toggle Dired-Omit mode.
+With numeric ARG, enable Dired-Omit mode if ARG is positive, disable
+otherwise. Enabling and disabling is buffer-local.
+If enabled, \"uninteresting\" files are not listed.
Uninteresting files are those whose filenames match regexp `dired-omit-files',
plus those ending with extensions in `dired-omit-extensions'."
- :type 'boolean
- :group 'dired-x)
-(make-variable-buffer-local 'dired-omit-files-p)
+ :group 'dired-x
+ (if dired-omit-mode
+ ;; This will mention how many lines were omitted:
+ (let ((dired-omit-size-limit nil)) (dired-omit-expunge))
+ (revert-buffer)))
+
+;; For backward compatibility
+(defvaralias 'dired-omit-files-p 'dired-omit-mode)
+(make-obsolete-variable 'dired-omit-files-p 'dired-omit-mode)
(defcustom dired-omit-files "^\\.?#\\|^\\.$\\|^\\.\\.$"
"*Filenames matching this regexp will not be displayed.
-This only has effect when `dired-omit-files-p' is t. See interactive function
-`dired-omit-toggle' \(\\[dired-omit-toggle]\) and variable
+This only has effect when `dired-omit-mode' is t. See interactive function
+`dired-omit-mode' \(\\[dired-omit-mode]\) and variable
`dired-omit-extensions'. The default is to omit `.', `..', auto-save
files and lock files."
:type 'regexp
@@ -230,7 +238,8 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
;;; KEY BINDINGS.
-(define-key dired-mode-map "\M-o" 'dired-omit-toggle)
+(define-key dired-mode-map "\M-o" 'dired-omit-mode)
+(define-key dired-mode-map "*O" 'dired-mark-omitted)
(define-key dired-mode-map "\M-(" 'dired-mark-sexp)
(define-key dired-mode-map "*(" 'dired-mark-sexp)
(define-key dired-mode-map "*." 'dired-mark-extension)
@@ -268,7 +277,7 @@ to nil: a pipe using `zcat' or `gunzip -c' will be used."
\\[dired-info]\t-- run info on file
\\[dired-man]\t-- run man on file
\\[dired-do-find-marked-files]\t-- visit all marked files simultaneously
- \\[dired-omit-toggle]\t-- toggle omitting of files
+ \\[dired-omit-mode]\t-- toggle omitting of files
\\[dired-mark-sexp]\t-- mark by Lisp expression
\\[dired-copy-filename-as-kill]\t-- copy the file or subdir names into the kill ring.
\t You can feed it to other commands using \\[yank].
@@ -280,7 +289,7 @@ For more features, see variables
`dired-bind-info'
`dired-bind-man'
`dired-vm-read-only-folders'
- `dired-omit-files-p'
+ `dired-omit-mode'
`dired-omit-files'
`dired-omit-extensions'
`dired-omit-size-limit'
@@ -450,9 +459,9 @@ buffer and try again."
(dired-insert-subdir (file-name-directory file))
(dired-goto-file file))
;; Toggle omitting, if it is on, and try again.
- (if dired-omit-files-p
+ (if dired-omit-mode
(progn
- (dired-omit-toggle)
+ (dired-omit-mode)
(dired-goto-file file))))))))
(defun dired-jump-other-window ()
@@ -479,31 +488,18 @@ need to match the entire file name.")
Should never be used as marker by the user or other packages.")
(defun dired-omit-startup ()
- (or (assq 'dired-omit-files-p minor-mode-alist)
+ (or (assq 'dired-omit-mode minor-mode-alist)
(setq minor-mode-alist
- (append '((dired-omit-files-p
+ (append '((dired-omit-mode
(:eval (if (eq major-mode 'dired-mode)
" Omit" ""))))
minor-mode-alist))))
-(defun dired-omit-toggle (&optional flag)
- "Toggle omitting files matching `dired-omit-files' and `dired-omit-extensions'.
-With an arg, and if omitting was off, don't toggle and just mark the
- files but don't actually omit them.
-With an arg, and if omitting was on, turn it off but don't refresh the buffer."
- (interactive "P")
- (if flag
- (if dired-omit-files-p
- (setq dired-omit-files-p (not dired-omit-files-p))
- (dired-mark-unmarked-files (dired-omit-regexp) nil nil
- dired-omit-localp))
- ;; no FLAG
- (setq dired-omit-files-p (not dired-omit-files-p))
- (if (not dired-omit-files-p)
- (revert-buffer)
- ;; this will mention how many were omitted:
- (let ((dired-omit-size-limit nil))
- (dired-omit-expunge)))))
+(defun dired-mark-omitted ()
+ "Mark files matching `dired-omit-files' and `dired-omit-extensions'."
+ (interactive)
+ (let ((dired-omit-mode nil)) (revert-buffer)) ;; Show omitted files
+ (dired-mark-unmarked-files (dired-omit-regexp) nil nil dired-omit-localp))
(defvar dired-omit-extensions
(append completion-ignored-extensions
@@ -515,12 +511,12 @@ Defaults to elements of `completion-ignored-extensions',
`dired-latex-unclean-extensions', `dired-bibtex-unclean-extensions', and
`dired-texinfo-unclean-extensions'.
-See interactive function `dired-omit-toggle' \(\\[dired-omit-toggle]\) and
-variables `dired-omit-files-p' and `dired-omit-files'.")
+See interactive function `dired-omit-mode' \(\\[dired-omit-mode]\) and
+variables `dired-omit-mode' and `dired-omit-files'.")
(defun dired-omit-expunge (&optional regexp)
"Erases all unmarked files matching REGEXP.
-Does nothing if global variable `dired-omit-files-p' is nil, or if called
+Does nothing if global variable `dired-omit-mode' is nil, or if called
non-interactively and buffer is bigger than `dired-omit-size-limit'.
If REGEXP is nil or not specified, uses `dired-omit-files', and also omits
filenames ending in `dired-omit-extensions'.
@@ -529,14 +525,14 @@ If REGEXP is the empty string, this function is a no-op.
This functions works by temporarily binding `dired-marker-char' to
`dired-omit-marker-char' and calling `dired-do-kill-lines'."
(interactive "sOmit files (regexp): ")
- (if (and dired-omit-files-p
+ (if (and dired-omit-mode
(or (interactive-p)
(not dired-omit-size-limit)
(< (buffer-size) dired-omit-size-limit)
(progn
(message "Not omitting: directory larger than %d characters."
dired-omit-size-limit)
- (setq dired-omit-files-p nil)
+ (setq dired-omit-mode nil)
nil)))
(let ((omit-re (or regexp (dired-omit-regexp)))
(old-modified-p (buffer-modified-p))
@@ -589,7 +585,7 @@ Second optional argument LOCALP is as in `dired-get-filename'."
(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
;; files that are going to be omitted anyway.
- (if dired-omit-files-p
+ (if dired-omit-mode
;; perhaps return t without calling ls
(let ((omit-re (dired-omit-regexp)))
(if (or (string= omit-re "")
@@ -842,7 +838,7 @@ dired."
(save-excursion
(set-buffer (get-buffer-create " *dot-dired*"))
(erase-buffer)
- (insert "Local Variables:\ndired-omit-files-p: t\nEnd:\n")
+ (insert "Local Variables:\ndired-omit-mode: t\nEnd:\n")
(write-file dired-local-variables-file)
(kill-buffer (current-buffer)))
@@ -1692,7 +1688,7 @@ If `current-prefix-arg' is non-nil, uses name at point as guess."
'dired-guess-shell-znew-switches
'dired-guess-shell-alist-user
'dired-clean-up-buffers-too
- 'dired-omit-files-p
+ 'dired-omit-mode
'dired-omit-files
'dired-omit-extensions
)
diff --git a/lisp/dired.el b/lisp/dired.el
index f562a0492eb..e5e23dfe2d6 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -60,6 +60,10 @@ some of the `ls' switches are not supported; see the doc string of
:type 'string
:group 'dired)
+(defvar dired-subdir-switches nil
+ "If non-nil, switches passed to `ls' for inserting subdirectories.
+If nil, `dired-listing-switches' is used.")
+
; Don't use absolute file names as /bin should be in any PATH and people
; may prefer /usr/local/gnu/bin or whatever. However, chown is
; usually not in PATH.
@@ -274,13 +278,18 @@ The directory name must be absolute, but need not be fully expanded.")
(defvar dired-re-perms "[-bcdlps][-r][-w].[-r][-w].[-r][-w].")
(defvar dired-re-dot "^.* \\.\\.?/?$")
-;; The subdirectory names in this list are expanded.
+;; The subdirectory names in the next two lists are expanded.
(defvar dired-subdir-alist nil
"Association list of subdirectories and their buffer positions.
Each subdirectory has an element: (DIRNAME . STARTMARKER).
The order of elements is the reverse of the order in the buffer.
In simple cases, this list contains one element.")
+(defvar dired-switches-alist nil
+ "Keeps track of which switches to use for inserted subdirectories.
+This is an alist of the form (SUBDIR . SWITCHES).")
+(make-variable-buffer-local 'dired-switches-alist)
+
(defvar dired-subdir-regexp "^. \\([^\n\r]+\\)\\(:\\)[\n\r]"
"Regexp matching a maybe hidden subdirectory line in `ls -lR' output.
Subexpression 1 is the subdirectory proper, no trailing colon.
@@ -871,7 +880,8 @@ Must also be called after dired-actual-switches have changed.
Should not fail even on completely garbaged buffers.
Preserves old cursor, marks/flags, hidden-p."
(widen) ; just in case user narrowed
- (let ((opoint (point))
+ (let ((modflag (buffer-modified-p))
+ (opoint (point))
(ofile (dired-get-filename nil t))
(mark-alist nil) ; save marked files
(hidden-subdirs (dired-remember-hidden))
@@ -898,9 +908,10 @@ Preserves old cursor, marks/flags, hidden-p."
(save-excursion ; hide subdirs that were hidden
(dolist (dir hidden-subdirs)
(if (dired-goto-subdir dir)
- (dired-hide-subdir 1)))))
+ (dired-hide-subdir 1))))
+ (unless modflag (restore-buffer-modified-p nil)))
;; outside of the let scope
-;;; Might as well not override the user if the user changed this.
+;;; Might as well not override the user if the user changed this.
;;; (setq buffer-read-only t)
)
@@ -1160,6 +1171,8 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
:help "Edit file at cursor"))
(define-key map [menu-bar immediate create-directory]
'(menu-item "Create Directory..." dired-create-directory))
+ (define-key map [menu-bar immediate wdired-mode]
+ '(menu-item "Edit File Names" wdired-change-to-wdired-mode))
(define-key map [menu-bar regexp]
(cons "Regexp" (make-sparse-keymap "Regexp")))
@@ -1402,6 +1415,9 @@ Keybindings:
(or switches dired-listing-switches))
(set (make-local-variable 'font-lock-defaults)
'(dired-font-lock-keywords t nil nil beginning-of-line))
+ (set (make-local-variable 'desktop-save-buffer)
+ 'dired-desktop-buffer-misc-data)
+ (setq dired-switches-alist nil)
(dired-sort-other dired-actual-switches t)
(run-mode-hooks 'dired-mode-hook)
(when (featurep 'x-dnd)
@@ -1427,14 +1443,13 @@ Keybindings:
(defun dired-undo ()
"Undo in a dired buffer.
This doesn't recover lost files, it just undoes changes in the buffer itself.
-You can use it to recover marks, killed lines or subdirs.
-In the latter case, you have to do \\[dired-build-subdir-alist] to
-parse the buffer again."
+You can use it to recover marks, killed lines or subdirs."
(interactive)
(let (buffer-read-only)
- (undo)
- (message "Change in Dired buffer undone.
-Actual changes in files cannot be undone by Emacs.")))
+ (undo))
+ (dired-build-subdir-alist)
+ (message "Change in Dired buffer undone.
+Actual changes in files cannot be undone by Emacs."))
(defun dired-next-line (arg)
"Move down lines then position at filename.
@@ -1630,9 +1645,7 @@ Otherwise, an error occurs in these cases."
((eq localp 'verbatim)
file)
((and (not no-error-if-not-filep)
- (save-excursion
- (beginning-of-line)
- (looking-at dired-re-dot)))
+ (member file '("." "..")))
(error "Cannot operate on `.' or `..'"))
((and (eq localp 'no-dir) already-absolute)
(file-name-nondirectory file))
@@ -1696,7 +1709,7 @@ DIR must be a directory name, not a file name."
(setq dir (expand-file-name dir)))
(if (string-match (concat "^" (regexp-quote dir)) file)
(substring file (match-end 0))
-;;; (or no-error
+;;; (or no-error
;;; (error "%s: not in directory tree growing at %s" file dir))
file))
@@ -2071,7 +2084,7 @@ instead of `dired-actual-switches'."
(goto-char (match-beginning 0))
(beginning-of-line)
(point-marker))))
- (if (> count 1)
+ (if (and (> count 1) (interactive-p))
(message "Buffer includes %d directories" count))
;; We don't need to sort it because it is in buffer order per
;; constructionem. Return new alist:
@@ -3018,244 +3031,6 @@ To be called first in body of `dired-sort-other', etc."
;; listing:
(list (car (reverse dired-subdir-alist))))))))
-;; To make this file smaller, the less common commands
-;; go in a separate file. But autoload them here
-;; to make the separation invisible.
-
-(autoload 'dired-diff "dired-aux"
- "Compare file at point with file FILE using `diff'.
-FILE defaults to the file at the mark. (That's the mark set by
-\\[set-mark-command], not by Dired's \\[dired-mark] command.)
-The prompted-for file is the first file given to `diff'."
- t)
-
-(autoload 'dired-backup-diff "dired-aux"
- "Diff this file with its backup file or vice versa.
-Uses the latest backup, if there are several numerical backups.
-If this file is a backup, diff it with its original.
-The backup file is the first file given to `diff'."
- t)
-
-(autoload 'dired-clean-directory "dired-aux"
- "Flag numerical backups for deletion.
-Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest.
-Positive prefix arg KEEP overrides `dired-kept-versions';
-Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive.
-
-To clear the flags on these files, you can use \\[dired-flag-backup-files]
-with a prefix argument."
- t)
-
-(autoload 'dired-do-chmod "dired-aux"
- "Change the mode of the marked (or next ARG) files.
-This calls chmod, thus symbolic modes like `g+w' are allowed."
- t)
-
-(autoload 'dired-do-chgrp "dired-aux"
- "Change the group of the marked (or next ARG) files."
- t)
-
-(autoload 'dired-do-chown "dired-aux"
- "Change the owner of the marked (or next ARG) files."
- t)
-
-(autoload 'dired-do-touch "dired-aux"
- "Change the timestamp of the marked (or next ARG) files."
- t)
-
-(autoload 'dired-do-print "dired-aux"
- "Print the marked (or next ARG) files.
-Uses the shell command coming from variables `lpr-command' and
-`lpr-switches' as default."
- t)
-
-(autoload 'dired-do-shell-command "dired-aux"
- "Run a shell command COMMAND on the marked files.
-If no files are marked or a specific numeric prefix arg is given,
-the next ARG files are used. Just \\[universal-argument] means the current file.
-The prompt mentions the file(s) or the marker, as appropriate.
-
-If there is a `*' in COMMAND, surrounded by whitespace, this runs
-COMMAND just once with the entire file list substituted there.
-
-If there is no `*', but there is a `?' in COMMAND, surrounded by
-whitespace, this runs COMMAND on each file individually with the
-file name substituted for `?'.
-
-Otherwise, this runs COMMAND on each file individually with the
-file name added at the end of COMMAND (separated by a space).
-
-`*' and `?' when not surrounded by whitespace have no special
-significance for `dired-do-shell-command', and are passed through
-normally to the shell, but you must confirm first. To pass `*' by
-itself to the shell as a wildcard, type `*\"\"'.
-
-If COMMAND produces output, it goes to a separate buffer.
-
-This feature does not try to redisplay Dired buffers afterward, as
-there's no telling what files COMMAND may have changed.
-Type \\[dired-do-redisplay] to redisplay the marked files.
-
-When COMMAND runs, its working directory is the top-level directory of
-the Dired buffer, so output files usually are created there instead of
-in a subdir.
-
-In a noninteractive call (from Lisp code), you must specify
-the list of file names explicitly with the FILE-LIST argument."
- t)
-
-(autoload 'dired-do-kill-lines "dired-aux"
- "Kill all marked lines (not the files).
-With a prefix arg, kill all lines not marked or flagged."
- t)
-
-(autoload 'dired-do-compress "dired-aux"
- "Compress or uncompress marked (or next ARG) files."
- t)
-
-(autoload 'dired-do-byte-compile "dired-aux"
- "Byte compile marked (or next ARG) Emacs Lisp files."
- t)
-
-(autoload 'dired-do-load "dired-aux"
- "Load the marked (or next ARG) Emacs Lisp files."
- t)
-
-(autoload 'dired-do-redisplay "dired-aux"
- "Redisplay all marked (or next ARG) files.
-If on a subdir line, redisplay that subdirectory. In that case,
-a prefix arg lets you edit the `ls' switches used for the new listing."
- t)
-
-(autoload 'dired-create-directory "dired-aux"
- "Create a directory called DIRECTORY."
- t)
-
-(autoload 'dired-do-copy "dired-aux"
- "Copy all marked (or next ARG) files, or copy the current file.
-Thus, a zero prefix argument copies nothing. But it toggles the
-variable `dired-copy-preserve-time' (which see)."
- t)
-
-(autoload 'dired-do-symlink "dired-aux"
- "Make symbolic links to current file or all marked (or next ARG) files.
-When operating on just the current file, you specify the new name.
-When operating on multiple or marked files, you specify a directory
-and new symbolic links are made in that directory
-with the same names that the files currently have."
- t)
-
-(autoload 'dired-do-hardlink "dired-aux"
- "Add names (hard links) current file or all marked (or next ARG) files.
-When operating on just the current file, you specify the new name.
-When operating on multiple or marked files, you specify a directory
-and new hard links are made in that directory
-with the same names that the files currently have."
- t)
-
-(autoload 'dired-do-rename "dired-aux"
- "Rename current file or all marked (or next ARG) files.
-When renaming just the current file, you specify the new name.
-When renaming multiple or marked files, you specify a directory."
- t)
-
-(autoload 'dired-do-rename-regexp "dired-aux"
- "Rename marked files containing REGEXP to NEWNAME.
-As each match is found, the user must type a character saying
- what to do with it. For directions, type \\[help-command] at that time.
-NEWNAME may contain \\=\\<n> or \\& as in `query-replace-regexp'.
-REGEXP defaults to the last regexp used.
-With a zero prefix arg, renaming by regexp affects the full file name;
-usually only the non-directory part of file names is used and changed."
- t)
-
-(autoload 'dired-do-copy-regexp "dired-aux"
- "Copy all marked files containing REGEXP to NEWNAME.
-See function `dired-do-rename-regexp' for more info."
- t)
-
-(autoload 'dired-do-hardlink-regexp "dired-aux"
- "Hardlink all marked files containing REGEXP to NEWNAME.
-See function `dired-do-rename-regexp' for more info."
- t)
-
-(autoload 'dired-do-symlink-regexp "dired-aux"
- "Symlink all marked files containing REGEXP to NEWNAME.
-See function `dired-do-rename-regexp' for more info."
- t)
-
-(autoload 'dired-upcase "dired-aux"
- "Rename all marked (or next ARG) files to upper case."
- t)
-
-(autoload 'dired-downcase "dired-aux"
- "Rename all marked (or next ARG) files to lower case."
- t)
-
-(autoload 'dired-maybe-insert-subdir "dired-aux"
- "Insert this subdirectory into the same dired buffer.
-If it is already present, just move to it (type \\[dired-do-redisplay] to refresh),
- else inserts it at its natural place (as `ls -lR' would have done).
-With a prefix arg, you may edit the ls switches used for this listing.
- You can add `R' to the switches to expand the whole tree starting at
- this subdirectory.
-This function takes some pains to conform to `ls -lR' output."
- t)
-
-(autoload 'dired-next-subdir "dired-aux"
- "Go to next subdirectory, regardless of level."
- t)
-
-(autoload 'dired-prev-subdir "dired-aux"
- "Go to previous subdirectory, regardless of level.
-When called interactively and not on a subdir line, go to this subdir's line."
- t)
-
-(autoload 'dired-goto-subdir "dired-aux"
- "Go to end of header line of DIR in this dired buffer.
-Return value of point on success, otherwise return nil.
-The next char is either \\n, or \\r if DIR is hidden."
- t)
-
-(autoload 'dired-mark-subdir-files "dired-aux"
- "Mark all files except `.' and `..'."
- t)
-
-(autoload 'dired-kill-subdir "dired-aux"
- "Remove all lines of current subdirectory.
-Lower levels are unaffected."
- t)
-
-(autoload 'dired-tree-up "dired-aux"
- "Go up ARG levels in the dired tree."
- t)
-
-(autoload 'dired-tree-down "dired-aux"
- "Go down in the dired tree."
- t)
-
-(autoload 'dired-hide-subdir "dired-aux"
- "Hide or unhide the current subdirectory and move to next directory.
-Optional prefix arg is a repeat factor.
-Use \\[dired-hide-all] to (un)hide all directories."
- t)
-
-(autoload 'dired-hide-all "dired-aux"
- "Hide all subdirectories, leaving only their header lines.
-If there is already something hidden, make everything visible again.
-Use \\[dired-hide-subdir] to (un)hide a particular subdirectory."
- t)
-
-(autoload 'dired-show-file-type "dired-aux"
- "Print the type of FILE, according to the `file' command.
-If FILE is a symbolic link and the optional argument DEREF-SYMLINKS is
-true then the type of the file linked to by FILE is printed instead."
- t)
-
-(autoload 'dired-run-shell-command "dired-aux")
-
-(autoload 'dired-query "dired-aux")
-
;;;; Drag and drop support
@@ -3272,16 +3047,16 @@ types in `x-dnd-known-types'. It returns the action suggested by the source."
nil)))
(defun dired-dnd-popup-notice ()
- (x-popup-dialog
+ (x-popup-dialog
t
- '("Recursive copies not enabled.\nSee variable dired-recursive-copies."
+ '("Recursive copies not enabled.\nSee variable dired-recursive-copies."
("Ok" . nil))))
(defun dired-dnd-do-ask-action (uri)
;; No need to get actions and descriptions from the source,
;; we only have three actions anyway.
- (let ((action (x-popup-menu
+ (let ((action (x-popup-menu
t
(list "What action?"
(cons ""
@@ -3340,7 +3115,49 @@ Ask means pop up a menu for the user to select one of copy, move or link."
(let ((local-file (x-dnd-get-local-file-uri uri)))
(if local-file (dired-dnd-handle-local-file local-file action)
nil)))
+
+
+;;;; Desktop support
+
+(eval-when-compile (require 'desktop))
+
+(defun dired-desktop-buffer-misc-data (desktop-dirname)
+ "Auxiliary information to be saved in desktop file."
+ (cons
+ ;; Value of `dired-directory'.
+ (if (consp dired-directory)
+ ;; Directory name followed by list of files.
+ (cons (desktop-file-name (car dired-directory) desktop-dirname)
+ (cdr dired-directory))
+ ;; Directory name, optionally with with shell wildcard.
+ (desktop-file-name dired-directory desktop-dirname))
+ ;; Subdirectories in `dired-subdir-alist'.
+ (cdr
+ (nreverse
+ (mapcar
+ (function (lambda (f) (desktop-file-name (car f) desktop-dirname)))
+ dired-subdir-alist)))))
+;;;###autoload
+(defun dired-restore-desktop-buffer (desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ "Restore a dired buffer specified in a desktop file."
+ ;; First element of `desktop-buffer-misc' is the value of `dired-directory'.
+ ;; This value is a directory name, optionally with with shell wildcard or
+ ;; a directory name followed by list of files.
+ (let* ((dired-dir (car desktop-buffer-misc))
+ (dir (if (consp dired-dir) (car dired-dir) dired-dir)))
+ (if (file-directory-p (file-name-directory dir))
+ (progn
+ (dired dired-dir)
+ ;; The following elements of `desktop-buffer-misc' are the keys
+ ;; from `dired-subdir-alist'.
+ (mapcar 'dired-maybe-insert-subdir (cdr desktop-buffer-misc))
+ (current-buffer))
+ (message "Desktop: Directory %s no longer exists." dir)
+ (when desktop-missing-file-warning (sit-for 1))
+ nil)))
(if (eq system-type 'vax-vms)
diff --git a/lisp/dos-fns.el b/lisp/dos-fns.el
index 65b6c0063c0..1253b7b5811 100644
--- a/lisp/dos-fns.el
+++ b/lisp/dos-fns.el
@@ -31,9 +31,13 @@
;; 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.
-This function's standard definition is trivial; it just returns the argument.
-However, on some systems, the function is redefined
-with a definition that really does change some file names."
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+On Windows and DOS, replace invalid characters. On DOS, make
+sure to obey the 8.3 limitations. On Windows, turn Cygwin names
+into native names, and also turn slashes into backslashes if the
+shell requires it (see `w32-shell-dos-semantics')."
(if (or (not (stringp filename))
;; This catches the case where FILENAME is "x:" or "x:/" or
;; "/", thus preventing infinite recursion.
diff --git a/lisp/ediff.el b/lisp/ediff.el
index 78ea48f4a1c..c98974923f1 100644
--- a/lisp/ediff.el
+++ b/lisp/ediff.el
@@ -1474,6 +1474,53 @@ With optional NODE, goes to that node."
(set-window-buffer ctl-window ctl-buf)))))))
+(dolist (mess '("^Errors in diff output. Diff output is in "
+ "^Hmm... I don't see an Ediff command around here...$"
+ "^Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer$"
+ ": This command runs in Ediff Control Buffer only!$"
+ ": Invalid op in ediff-check-version$"
+ "^ediff-shrink-window-C can be used only for merging jobs$"
+ "^Lost difference info on these directories$"
+ "^This command is inapplicable in the present context$"
+ "^This session group has no parent$"
+ "^Can't hide active session, $"
+ "^Ediff: something wrong--no multiple diffs buffer$"
+ "^Can't make context diff for Session $"
+ "^The patch buffer wasn't found$"
+ "^Aborted$"
+ "^This Ediff session is not part of a session group$"
+ "^No active Ediff sessions or corrupted session registry$"
+ "^No session info in this line$"
+ "^`.*' is not an ordinary file$"
+ "^Patch appears to have failed$"
+ "^Recomputation of differences cancelled$"
+ "^No fine differences in this mode$"
+ "^Lost connection to ancestor buffer...sorry$"
+ "^Not merging with ancestor$"
+ "^Don't know how to toggle read-only in buffer "
+ "Emacs is not running as a window application$"
+ "^This command makes sense only when merging with an ancestor$"
+ "^At end of the difference list$"
+ "^At beginning of the difference list$"
+ "^Nothing saved for diff .* in buffer "
+ "^Buffer is out of sync for file "
+ "^Buffer out of sync for file "
+ "^Output from `diff' not found$"
+ "^You forgot to specify a region in buffer "
+ "^All right. Make up your mind and come back...$"
+ "^Current buffer is not visiting any file$"
+ "^Failed to retrieve revision: $"
+ "^Can't determine display width.$"
+ "^File `.*' does not exist or is not readable$"
+ "^File `.*' is a directory$"
+ "^Buffer .* doesn't exist$"
+ "^Directories . and . are the same: "
+ "^Directory merge aborted$"
+ "^Merge of directory revisions aborted$"
+ "^Buffer .* doesn't exist$"
+ "^There is no file to merge$"
+ "^Version control package .*.el not found. Use vc.el instead$"))
+ (add-to-list 'debug-ignored-errors mess))
;;; Local Variables:
diff --git a/lisp/ehelp.el b/lisp/ehelp.el
index 12ebbeb0c0d..e80c129d3ea 100644
--- a/lisp/ehelp.el
+++ b/lisp/ehelp.el
@@ -1,6 +1,6 @@
;;; ehelp.el --- bindings for electric-help mode
-;; Copyright (C) 1986, 1995, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1995, 2000, 2001, 2004 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: help, extensions
@@ -200,13 +200,13 @@ BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit."
(progn (setq unread-command-events nil)
(throw 'exit t)))))
(let (up down both neither
- (standard (and (eq (key-binding " ")
+ (standard (and (eq (key-binding " " nil t)
'scroll-up)
- (eq (key-binding "\^?")
+ (eq (key-binding "\^?" nil t)
'scroll-down)
- (eq (key-binding "q")
+ (eq (key-binding "q" nil t)
'electric-help-exit)
- (eq (key-binding "r")
+ (eq (key-binding "r" nil t)
'electric-help-retain))))
(Electric-command-loop
'exit
@@ -215,7 +215,7 @@ BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit."
;beginning-of-buffer - otherwise pos-visible-in-window-p
;will yield a wrong result.
(let ((min (pos-visible-in-window-p (point-min)))
- (max (pos-visible-in-window-p (point-max))))
+ (max (pos-visible-in-window-p (1- (point-max)))))
(cond (isearch-mode 'noprompt)
((and min max)
(cond (standard "Press q to exit, r to retain ")
@@ -272,7 +272,7 @@ will select it.)"
(interactive)
(error "%s is undefined -- Press %s to exit"
(mapconcat 'single-key-description (this-command-keys) " ")
- (if (eq (key-binding "q") 'electric-help-exit)
+ (if (eq (key-binding "q" nil t) 'electric-help-exit)
"q"
(substitute-command-keys "\\[electric-help-exit]"))))
@@ -280,10 +280,10 @@ will select it.)"
;>>> this needs to be hairified (recursive help, anybody?)
(defun electric-help-help ()
(interactive)
- (if (and (eq (key-binding "q") 'electric-help-exit)
- (eq (key-binding " ") 'scroll-up)
- (eq (key-binding "\^?") 'scroll-down)
- (eq (key-binding "r") 'electric-help-retain))
+ (if (and (eq (key-binding "q" nil t) 'electric-help-exit)
+ (eq (key-binding " " nil t) 'scroll-up)
+ (eq (key-binding "\^?" nil t) 'scroll-down)
+ (eq (key-binding "r" nil t) 'electric-help-retain))
(message "SPC scrolls up, DEL scrolls down, q exits burying help buffer, r exits")
(message "%s" (substitute-command-keys "\\[scroll-up] scrolls up, \\[scroll-down] scrolls down, \\[electric-help-exit] exits burying help buffer, \\[electric-help-retain] exits")))
(sit-for 2))
diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el
index 43da3d09827..21843c9601d 100644
--- a/lisp/emacs-lisp/autoload.el
+++ b/lisp/emacs-lisp/autoload.el
@@ -1,6 +1,6 @@
;; autoload.el --- maintain autoloads in loaddefs.el
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2001, 2003
+;; Copyright (C) 1991,92,93,94,95,96,97, 2001,02,03,04
;; Free Software Foundation, Inc.
;; Author: Roland McGrath <roland@gnu.org>
@@ -407,7 +407,7 @@ Return FILE if there was no autoload cookie in it."
(if (and (or (null existing-buffer)
(not (buffer-modified-p existing-buffer)))
(listp last-time) (= (length last-time) 2)
- (not (autoload-before-p last-time file-time)))
+ (not (time-less-p last-time file-time)))
(progn
(if (interactive-p)
(message "\
@@ -468,11 +468,6 @@ Autoload section for %s is up to date."
(if no-autoloads file))))
-(defun autoload-before-p (time1 time2)
- (or (< (car time1) (car time2))
- (and (= (car time1) (car time2))
- (< (nth 1 time1) (nth 1 time2)))))
-
(defun autoload-remove-section (begin)
(goto-char begin)
(search-forward generate-autoload-section-trailer)
@@ -527,8 +522,7 @@ directory or directories specified."
(dolist (file file)
(let ((file-time (nth 5 (file-attributes file))))
(when (and file-time
- (not (autoload-before-p last-time
- file-time)))
+ (not (time-less-p last-time file-time)))
;; file unchanged
(push file no-autoloads)
(setq files (delete file files)))))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 9956d5003cc..2cd0896c835 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -76,21 +76,21 @@
(eval-and-compile
(put ',name 'byte-optimizer 'byte-compile-inline-expand))))
-(defun make-obsolete (fn new &optional when)
+(defun make-obsolete (function new &optional when)
"Make the byte-compiler warn that FUNCTION is obsolete.
The warning will say that NEW should be used instead.
If NEW is a string, that is the `use instead' message.
If provided, WHEN should be a string indicating when the function
was first made obsolete, for example a date or a release number."
(interactive "aMake function obsolete: \nxObsoletion replacement: ")
- (let ((handler (get fn 'byte-compile)))
+ (let ((handler (get function 'byte-compile)))
(if (eq 'byte-compile-obsolete handler)
- (setq handler (nth 1 (get fn 'byte-obsolete-info)))
- (put fn 'byte-compile 'byte-compile-obsolete))
- (put fn 'byte-obsolete-info (list new handler when)))
- fn)
+ (setq handler (nth 1 (get function 'byte-obsolete-info)))
+ (put function 'byte-compile 'byte-compile-obsolete))
+ (put function 'byte-obsolete-info (list new handler when)))
+ function)
-(defun make-obsolete-variable (var new &optional when)
+(defun make-obsolete-variable (variable new &optional when)
"Make the byte-compiler warn that VARIABLE is obsolete.
The warning will say that NEW should be used instead.
If NEW is a string, that is the `use instead' message.
@@ -102,8 +102,8 @@ was first made obsolete, for example a date or a release number."
(if (equal str "") (error ""))
(intern str))
(car (read-from-string (read-string "Obsoletion replacement: ")))))
- (put var 'byte-obsolete-variable (cons new when))
- var)
+ (put variable 'byte-obsolete-variable (cons new when))
+ variable)
(put 'dont-compile 'lisp-indent-hook 0)
(defmacro dont-compile (&rest body)
@@ -134,11 +134,10 @@ The result of the body appears to the compiler as a quoted constant."
;; Remember, it's magic.
(cons 'progn body))
-(defun with-no-warnings (&optional first &rest body)
+(defun with-no-warnings (&rest body)
"Like `progn', but prevents compiler warnings in the body."
;; The implementation for the interpreter is basically trivial.
- (if body (car (last body))
- first))
+ (car (last body)))
;;; I nuked this because it's not a good idea for users to think of using it.
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 3e3bfe2a074..c1a43722415 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -832,24 +832,22 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Log something that isn't a warning.
(defmacro byte-compile-log (format-string &rest args)
- (list 'and
- 'byte-optimize
- '(memq byte-optimize-log '(t source))
- (list 'let '((print-escape-newlines t)
- (print-level 4)
- (print-length 4))
- (list 'byte-compile-log-1
- (cons 'format
- (cons format-string
- (mapcar
- (lambda (x)
- (if (symbolp x) (list 'prin1-to-string x) x))
- args)))))))
+ `(and
+ byte-optimize
+ (memq byte-optimize-log '(t source))
+ (let ((print-escape-newlines t)
+ (print-level 4)
+ (print-length 4))
+ (byte-compile-log-1
+ (format
+ ,format-string
+ ,@(mapcar
+ (lambda (x) (if (symbolp x) (list 'prin1-to-string x) x))
+ args))))))
;; Log something that isn't a warning.
(defun byte-compile-log-1 (string)
- (save-excursion
- (byte-goto-log-buffer)
+ (with-current-buffer "*Compile-Log*"
(goto-char (point-max))
(byte-compile-warning-prefix nil nil)
(cond (noninteractive
@@ -903,11 +901,6 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(defvar byte-compile-last-warned-form nil)
(defvar byte-compile-last-logged-file nil)
-(defun byte-goto-log-buffer ()
- (set-buffer (get-buffer-create "*Compile-Log*"))
- (unless (eq major-mode 'compilation-mode)
- (compilation-mode)))
-
;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
@@ -983,6 +976,7 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
;; Do this after setting default-directory.
(unless (eq major-mode 'compilation-mode)
(compilation-mode))
+ (compilation-forget-errors)
pt))))
;; Log a message STRING in *Compile-Log*.
@@ -1014,11 +1008,11 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
(when (nth 2 new)))
(byte-compile-set-symbol-position (car form))
(if (memq 'obsolete byte-compile-warnings)
- (byte-compile-warn "%s is an obsolete function%s; %s" (car form)
+ (byte-compile-warn "`%s' is an obsolete function%s; %s" (car form)
(if when (concat " since " when) "")
(if (stringp (car new))
(car new)
- (format "use %s instead." (car new)))))
+ (format "use `%s' instead." (car new)))))
(funcall (or handler 'byte-compile-normal-call) form)))
;; Compiler options
@@ -2082,7 +2076,7 @@ list that represents a doc string reference.
(defun byte-compile-file-form-defsubst (form)
(when (assq (nth 1 form) byte-compile-unresolved-functions)
(setq byte-compile-current-form (nth 1 form))
- (byte-compile-warn "defsubst %s was used before it was defined"
+ (byte-compile-warn "defsubst `%s' was used before it was defined"
(nth 1 form)))
(byte-compile-file-form
(macroexpand form byte-compile-macro-environment))
@@ -2212,7 +2206,7 @@ list that represents a doc string reference.
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
(byte-compile-warn
- "%s defined multiple times, as both function and macro"
+ "`%s' defined multiple times, as both function and macro"
(nth 1 form)))
(setcdr that-one nil))
(this-one
@@ -2221,14 +2215,14 @@ list that represents a doc string reference.
;; byte-compiler macros in byte-run.el...
(not (assq (nth 1 form)
byte-compile-initial-macro-environment)))
- (byte-compile-warn "%s %s defined multiple times in this file"
+ (byte-compile-warn "%s `%s' defined multiple times in this file"
(if macrop "macro" "function")
(nth 1 form))))
((and (fboundp name)
(eq (car-safe (symbol-function name))
(if macrop 'lambda 'macro)))
(when (memq 'redefine byte-compile-warnings)
- (byte-compile-warn "%s %s being redefined as a %s"
+ (byte-compile-warn "%s `%s' being redefined as a %s"
(if macrop "function" "macro")
(nth 1 form)
(if macrop "macro" "function")))
@@ -2701,7 +2695,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(handler (get fn 'byte-compile)))
(byte-compile-set-symbol-position fn)
(when (byte-compile-const-symbol-p fn)
- (byte-compile-warn "%s called as a function" fn))
+ (byte-compile-warn "`%s' called as a function" fn))
(if (and handler
(or (not (byte-compile-version-cond
byte-compile-compatibility))
@@ -2736,9 +2730,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (or (not (symbolp var))
(byte-compile-const-symbol-p var (not (eq base-op 'byte-varref))))
(byte-compile-warn
- (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s %s")
- ((eq base-op 'byte-varset) "variable assignment to %s %s")
- (t "variable reference to %s %s"))
+ (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'")
+ ((eq base-op 'byte-varset) "variable assignment to %s `%s'")
+ (t "variable reference to %s `%s'"))
(if (symbolp var) "constant" "nonvariable")
(prin1-to-string var))
(if (and (get var 'byte-obsolete-variable)
@@ -2746,11 +2740,11 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(not (eq var byte-compile-not-obsolete-var)))
(let* ((ob (get var 'byte-obsolete-variable))
(when (cdr ob)))
- (byte-compile-warn "%s is an obsolete variable%s; %s" var
+ (byte-compile-warn "`%s' is an obsolete variable%s; %s" var
(if when (concat " since " when) "")
(if (stringp (car ob))
(car ob)
- (format "use %s instead." (car ob))))))
+ (format "use `%s' instead." (car ob))))))
(if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind)
(push var byte-compile-bound-variables)
@@ -2759,11 +2753,11 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (eq base-op 'byte-varset)
(or (memq var byte-compile-free-assignments)
(progn
- (byte-compile-warn "assignment to free variable %s" var)
+ (byte-compile-warn "assignment to free variable `%s'" var)
(push var byte-compile-free-assignments)))
(or (memq var byte-compile-free-references)
(progn
- (byte-compile-warn "reference to free variable %s" var)
+ (byte-compile-warn "reference to free variable `%s'" var)
(push var byte-compile-free-references))))))))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
@@ -2964,7 +2958,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(defun byte-compile-subr-wrong-args (form n)
(byte-compile-set-symbol-position (car form))
- (byte-compile-warn "%s called with %d arg%s, but requires %s"
+ (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
(car form) (length (cdr form))
(if (= 1 (length (cdr form))) "" "s") n)
;; get run-time wrong-number-of-args error.
@@ -3130,7 +3124,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(if (and (consp (car body))
(not (eq 'byte-code (car (car body)))))
(byte-compile-warn
- "A quoted lambda form is the second argument of fset. This is probably
+ "A quoted lambda form is the second argument of `fset'. This is probably
not what you want, as that lambda cannot be compiled. Consider using
the syntax (function (lambda (...) ...)) instead.")))))
(byte-compile-two-args form))
@@ -3515,7 +3509,7 @@ being undefined will be suppressed."
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
(byte-compile-warn
- "%s is not a variable-name or nil (in condition-case)" var))
+ "`%s' is not a variable-name or nil (in condition-case)" var))
(byte-compile-push-constant var)
(byte-compile-push-constant (byte-compile-top-level
(nth 2 form) for-effect))
@@ -3533,13 +3527,13 @@ being undefined will be suppressed."
(setq syms (cdr syms)))
ok))))
(byte-compile-warn
- "%s is not a condition name or list of such (in condition-case)"
+ "`%s' is not a condition name or list of such (in condition-case)"
(prin1-to-string condition)))
;; ((not (or (eq condition 't)
;; (and (stringp (get condition 'error-message))
;; (consp (get condition 'error-conditions)))))
;; (byte-compile-warn
-;; "%s is not a known condition name (in condition-case)"
+;; "`%s' is not a known condition name (in condition-case)"
;; condition))
)
(setq compiled-clauses
@@ -3635,7 +3629,7 @@ being undefined will be suppressed."
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
(byte-compile-warn
- "%s called with %d argument%s, but %s %s"
+ "`%s' called with %d argument%s, but %s %s"
fun ncall
(if (= 1 ncall) "" "s")
(if (< ncall 2) "requires" "accepts only")
@@ -3652,7 +3646,7 @@ being undefined will be suppressed."
`(push ',var current-load-list))
(when (> (length form) 3)
(when (and string (not (stringp string)))
- (byte-compile-warn "third arg to %s %s is not a string: %s"
+ (byte-compile-warn "third arg to `%s %s' is not a string: %s"
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cddr form) ; `value' provided
@@ -3718,7 +3712,7 @@ being undefined will be suppressed."
(byte-defop-compiler-1 with-no-warnings byte-compile-no-warnings)
(defun byte-compile-no-warnings (form)
(let (byte-compile-warnings)
- (byte-compile-form (cadr form))))
+ (byte-compile-form (cons 'progn (cdr form)))))
;;; tags
@@ -3993,7 +3987,7 @@ already up-to-date."
nil))))
;;;###autoload
-(defun batch-byte-recompile-directory ()
+(defun batch-byte-recompile-directory (&optional arg)
"Run `byte-recompile-directory' on the dirs remaining on the command line.
Must be used only with `-batch', and kills Emacs on completion.
For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
@@ -4004,7 +3998,7 @@ For example, invoke `emacs -batch -f batch-byte-recompile-directory .'."
(or command-line-args-left
(setq command-line-args-left '(".")))
(while command-line-args-left
- (byte-recompile-directory (car command-line-args-left))
+ (byte-recompile-directory (car command-line-args-left) arg)
(setq command-line-args-left (cdr command-line-args-left)))
(kill-emacs 0))
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index fddab94dfd4..2aba3ea254c 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -1246,7 +1246,7 @@ generating a buffered list of errors."
With prefix ARG, turn Checkdoc minor mode on iff ARG is positive.
In Checkdoc minor mode, the usual bindings for `eval-defun' which is
-bound to \\<checkdoc-minor-mode-map> \\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
+bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include
checking of documentation strings.
\\{checkdoc-minor-mode-map}"
@@ -2579,86 +2579,52 @@ This function will not modify `match-data'."
;;; Warning management
;;
(defvar checkdoc-output-font-lock-keywords
- '(("\\(\\w+\\.el\\): \\(\\w+\\)"
+ '(("^\\*\\*\\* \\(.+\\.el\\): \\([^ \n]+\\)"
(1 font-lock-function-name-face)
- (2 font-lock-comment-face))
- ("^\\(\\w+\\.el\\):" 1 font-lock-function-name-face)
- (":\\([0-9]+\\):" 1 font-lock-constant-face))
+ (2 font-lock-comment-face)))
"Keywords used to highlight a checkdoc diagnostic buffer.")
-(defvar checkdoc-output-mode-map nil
- "Keymap used in `checkdoc-output-mode'.")
+(defvar checkdoc-output-error-regex-alist
+ '(("^\\(.+\\.el\\):\\([0-9]+\\): " 1 2)))
(defvar checkdoc-pending-errors nil
"Non-nil when there are errors that have not been displayed yet.")
-(if checkdoc-output-mode-map
- nil
- (setq checkdoc-output-mode-map (make-sparse-keymap))
- (if (not (string-match "XEmacs" emacs-version))
- (define-key checkdoc-output-mode-map [mouse-2]
- 'checkdoc-find-error))
- (define-key checkdoc-output-mode-map "\C-c\C-c" 'checkdoc-find-error)
- (define-key checkdoc-output-mode-map "\C-m" 'checkdoc-find-error))
-
-(defun checkdoc-output-mode ()
- "Create and setup the buffer used to maintain checkdoc warnings.
-\\<checkdoc-output-mode-map>\\[checkdoc-find-error] - Go to this error location."
- (if (get-buffer checkdoc-diagnostic-buffer)
- (get-buffer checkdoc-diagnostic-buffer)
- (save-excursion
- (set-buffer (get-buffer-create checkdoc-diagnostic-buffer))
- (kill-all-local-variables)
- (setq mode-name "Checkdoc"
- major-mode 'checkdoc-output-mode)
- (set (make-local-variable 'font-lock-defaults)
- '((checkdoc-output-font-lock-keywords) t t ((?- . "w") (?_ . "w"))))
- (use-local-map checkdoc-output-mode-map)
- (run-hooks 'checkdoc-output-mode-hook)
- (current-buffer))))
-
-(defalias 'checkdoc-find-error-mouse 'checkdoc-find-error)
-(defun checkdoc-find-error (&optional event)
- "In a checkdoc diagnostic buffer, find the error under point."
- (interactive (list last-input-event))
- (if event (posn-set-point (event-end e)))
- (beginning-of-line)
- (if (looking-at "\\(\\(\\w+\\|\\s_\\)+\\.el\\):\\([0-9]+\\):")
- (let ((l (string-to-int (match-string 3)))
- (f (match-string 1)))
- (if (not (get-file-buffer f))
- (error "Can't find buffer %s" f))
- (switch-to-buffer-other-window (get-file-buffer f))
- (goto-line l))))
+(define-derived-mode checkdoc-output-mode compilation-mode "Checkdoc"
+ "Set up the major mode for the buffer containing the list of errors."
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ checkdoc-output-error-regex-alist)
+ (set (make-local-variable 'compilation-mode-font-lock-keywords)
+ checkdoc-output-font-lock-keywords))
(defun checkdoc-buffer-label ()
"The name to use for a checkdoc buffer in the error list."
(if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
+ (file-relative-name (buffer-file-name))
(concat "#<buffer "(buffer-name) ">")))
(defun checkdoc-start-section (check-type)
"Initialize the checkdoc diagnostic buffer for a pass.
Create the header so that the string CHECK-TYPE is displayed as the
function called to create the messages."
- (checkdoc-output-to-error-buffer
- "\n\n\C-l\n*** "
- (checkdoc-buffer-label) ": " check-type " V " checkdoc-version))
+ (let ((dir default-directory)
+ (label (checkdoc-buffer-label)))
+ (with-current-buffer (get-buffer-create checkdoc-diagnostic-buffer)
+ (checkdoc-output-mode)
+ (setq default-directory dir)
+ (goto-char (point-max))
+ (insert "\n\n\C-l\n*** " label ": " check-type " V " checkdoc-version))))
(defun checkdoc-error (point msg)
"Store POINT and MSG as errors in the checkdoc diagnostic buffer."
(setq checkdoc-pending-errors t)
- (checkdoc-output-to-error-buffer
- "\n" (checkdoc-buffer-label) ":"
- (int-to-string (count-lines (point-min) (or point (point-min)))) ": "
- msg))
-
-(defun checkdoc-output-to-error-buffer (&rest text)
- "Place TEXT into the checkdoc diagnostic buffer."
- (save-excursion
- (set-buffer (checkdoc-output-mode))
- (goto-char (point-max))
- (apply 'insert text)))
+ (let ((text (list "\n" (checkdoc-buffer-label) ":"
+ (int-to-string
+ (count-lines (point-min) (or point (point-min))))
+ ": " msg)))
+ (with-current-buffer (get-buffer checkdoc-diagnostic-buffer)
+ (goto-char (point-max))
+ (apply 'insert text))))
(defun checkdoc-show-diagnostics ()
"Display the checkdoc diagnostic buffer in a temporary window."
diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el
index 2e6265d4dfd..c5e13a4c00f 100644
--- a/lisp/emacs-lisp/cl-indent.el
+++ b/lisp/emacs-lisp/cl-indent.el
@@ -216,8 +216,12 @@ If nil, indent backquoted lists as data, i.e., like quoted lists."
(cond ((string-match "\\`def"
function)
(setq tentative-defun t))
- ((string-match "\\`\\(with\\|do\\)-"
- function)
+ ((string-match
+ (eval-when-compile
+ (concat "\\`\\("
+ (regexp-opt '("with" "without" "do"))
+ "\\)-"))
+ function)
(setq method '(&lambda &body))))))
;; backwards compatibility. Bletch.
((eq method 'defun)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index c61c275f2b0..68f823b88f3 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -164,21 +164,21 @@
;;; Symbols.
(defvar *gensym-counter*)
-(defun gensym (&optional arg)
+(defun gensym (&optional prefix)
"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
- (num (if (integerp arg) arg
+ (let ((pfix (if (stringp prefix) prefix "G"))
+ (num (if (integerp prefix) prefix
(prog1 *gensym-counter*
(setq *gensym-counter* (1+ *gensym-counter*))))))
- (make-symbol (format "%s%d" prefix num))))
+ (make-symbol (format "%s%d" pfix num))))
-(defun gentemp (&optional arg)
+(defun gentemp (&optional prefix)
"Generate a new interned symbol with a unique name.
The name is made by appending a number to PREFIX, default \"G\"."
- (let ((prefix (if (stringp arg) arg "G"))
+ (let ((pfix (if (stringp prefix) prefix "G"))
name)
- (while (intern-soft (setq name (format "%s%d" prefix *gensym-counter*)))
+ (while (intern-soft (setq name (format "%s%d" pfix *gensym-counter*)))
(setq *gensym-counter* (1+ *gensym-counter*)))
(intern name)))
@@ -1177,12 +1177,14 @@ Valid clauses are:
(defmacro do (steps endtest &rest body)
"The Common Lisp `do' loop.
-Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+
+\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(cl-expand-do-loop steps endtest body nil))
(defmacro do* (steps endtest &rest body)
"The Common Lisp `do*' loop.
-Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
+
+\(fn ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)"
(cl-expand-do-loop steps endtest body t))
(defun cl-expand-do-loop (steps endtest body star)
@@ -2398,10 +2400,10 @@ The type name can then be used in `typecase', `check-type', etc."
((eq (car type) 'satisfies) (list (cadr type) val))
(t (error "Bad type spec: %s" type)))))
-(defun typep (val type) ; See compiler macro below.
+(defun typep (object type) ; See compiler macro below.
"Check that OBJECT is of type TYPE.
TYPE is a Common Lisp-style type specifier."
- (eval (cl-make-type-test 'val type)))
+ (eval (cl-make-type-test 'object type)))
(defmacro check-type (form type &optional string)
"Verify that FORM is of type TYPE; signal an error if not.
@@ -2438,8 +2440,8 @@ omitted, a default message listing FORM itself is used."
nil))))
(defmacro ignore-errors (&rest body)
- "Execute FORMS; if an error occurs, return nil.
-Otherwise, return result of last FORM."
+ "Execute BODY; if an error occurs, return nil.
+Otherwise, return result of last form in BODY."
`(condition-case nil (progn ,@body) (error nil)))
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index d8890bd0239..ed632b14cd4 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -4,7 +4,7 @@
;; Author: Doug Cutting <doug@csli.stanford.edu>
;; Jamie Zawinski <jwz@lucid.com>
-;; Maintainer: Jamie Zawinski <jwz@lucid.com>
+;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
@@ -57,7 +57,7 @@ redefine OBJECT if it is a symbol."
(interactive (list (intern (completing-read "Disassemble function: "
obarray 'fboundp t))
nil 0 t))
- (if (consp object)
+ (if (and (consp object) (not (eq (car object) 'lambda)))
(setq object (list 'lambda () object)))
(or indent (setq indent 0)) ;Default indent to zero
(save-excursion
diff --git a/lisp/emacs-lisp/easymenu.el b/lisp/emacs-lisp/easymenu.el
index 88f7657b6bf..dbd7194f50a 100644
--- a/lisp/emacs-lisp/easymenu.el
+++ b/lisp/emacs-lisp/easymenu.el
@@ -478,8 +478,8 @@ Do it only if `easy-menu-precalculate-equivalent-keybindings' is on."
(when easy-menu-precalculate-equivalent-keybindings
(if (and (symbolp menu) (not (keymapp menu)) (boundp menu))
(setq menu (symbol-value menu)))
- ;; x-popup-menu does not exist on tty-only Emacs.
- ;; (if (keymapp menu) (x-popup-menu nil menu))
+ (and (keymapp menu) (fboundp 'x-popup-menu)
+ (x-popup-menu nil menu))
))
(defun add-submenu (menu-path submenu &optional before in-menu)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 8a924d045f7..9a7b9efc333 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -477,7 +477,8 @@ also dependent on the values of `edebug-all-defs' and
If the current defun is actually a call to `defvar', then reset the
variable using its initial value expression even if the variable
already has some other value. (Normally `defvar' does not change the
-variable's value if it already has a value.)
+variable's value if it already has a value.) Treat `defcustom'
+similarly. Reinitialize the face according to `defface' specification.
With a prefix argument, instrument the code for Edebug.
@@ -507,7 +508,12 @@ the minibuffer."
((and (eq (car form) 'defcustom)
(default-boundp (nth 1 form)))
;; Force variable to be bound.
- (set-default (nth 1 form) (eval (nth 2 form)))))
+ (set-default (nth 1 form) (eval (nth 2 form))))
+ ((eq (car form) 'defface)
+ ;; Reset the face.
+ (put (nth 1 form) 'face-defface-spec nil)
+ (setq face-new-frame-defaults
+ (assq-delete-all (nth 1 form) face-new-frame-defaults))))
(setq edebug-result (eval form))
(if (not edebugging)
(princ edebug-result)
@@ -3692,8 +3698,7 @@ Return the result of the last expression."
(setq edebug-previous-result
(concat "Result: "
(edebug-safe-prin1-to-string edebug-previous-value)
- (let ((name (prin1-char edebug-previous-value)))
- (if name (concat " = " name))))))
+ (eval-expression-print-format edebug-previous-value))))
(defun edebug-previous-result ()
"Print the previous result."
@@ -3712,7 +3717,8 @@ Print result in minibuffer."
(princ
(edebug-outside-excursion
(setq values (cons (edebug-eval edebug-expr) values))
- (edebug-safe-prin1-to-string (car values)))))
+ (concat (edebug-safe-prin1-to-string (car values))
+ (eval-expression-print-format (car values))))))
(defun edebug-eval-last-sexp ()
"Evaluate sexp before point in the outside environment; value in minibuffer."
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index a0c2e3c0d70..a2cb4e9fe46 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -1,6 +1,7 @@
;;; ewoc.el --- utility to maintain a view of a list of objects in a buffer
-;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000 Free Software Foundation
+;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 04
+;; Free Software Foundation
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
@@ -244,7 +245,7 @@ BUT if it is the header or the footer in EWOC return nil instead."
(defun ewoc--create-node (data pretty-printer pos)
"Call PRETTY-PRINTER with point set at POS in current buffer.
-Remember the start position. Create a wrapper containing that
+Remember the start position. Create a wrapper containing that
start position and the element DATA."
(save-excursion
;; Remember the position as a number so that it doesn't move
@@ -263,7 +264,7 @@ start position and the element DATA."
(defun ewoc--delete-node-internal (ewoc node)
"Delete a data string from EWOC.
-Can not be used on the footer. Returns the wrapper that is deleted.
+Can not be used on the footer. Returns the wrapper that is deleted.
The start-marker in the wrapper is set to nil, so that it doesn't
consume any more resources."
(let ((dll (ewoc--dll ewoc))
@@ -303,14 +304,14 @@ The ewoc will be inserted in the current buffer at the current position.
PRETTY-PRINTER should be a function that takes one argument, an
element, and inserts a string representing it in the buffer (at
-point). The string PRETTY-PRINTER inserts may be empty or span
-several linse. A trailing newline will always be inserted
-automatically. The PRETTY-PRINTER should use insert, and not
-insert-before-markers.
-
-Optional third argument HEADER is a string that will always be
-present at the top of the ewoc. HEADER should end with a
-newline. Optionaly fourth argument FOOTER is similar, and will
+point). The string PRETTY-PRINTER inserts may be empty or span
+several lines. A trailing newline will always be inserted
+automatically. The PRETTY-PRINTER should use `insert', and not
+`insert-before-markers'.
+
+Optional second argument HEADER is a string that will always be
+present at the top of the ewoc. HEADER should end with a
+newline. Optional third argument FOOTER is similar, and will
be inserted at the bottom of the ewoc."
(let ((new-ewoc
(ewoc--create (current-buffer)
@@ -394,9 +395,9 @@ MAP-FUNCTION is applied to the first element first.
If MAP-FUNCTION returns non-nil the element will be refreshed (its
pretty-printer will be called once again).
-Note that the buffer for EWOC will be current buffer when MAP-FUNCTION
-is called. MAP-FUNCTION must restore the current buffer to BUFFER before
-it returns, if it changes it.
+Note that the buffer for EWOC will be the current buffer when
+MAP-FUNCTION is called. MAP-FUNCTION must restore the current
+buffer before it returns, if it changes it.
If more than two arguments are given, the remaining
arguments will be passed to MAP-FUNCTION."
@@ -411,9 +412,9 @@ arguments will be passed to MAP-FUNCTION."
(defun ewoc-filter (ewoc predicate &rest args)
"Remove all elements in EWOC for which PREDICATE returns nil.
Note that the buffer for EWOC will be current-buffer when PREDICATE
-is called. PREDICATE must restore the current buffer before it returns
+is called. PREDICATE must restore the current buffer before it returns
if it changes it.
-The PREDICATE is called with the element as its first argument. If any
+The PREDICATE is called with the element as its first argument. If any
ARGS are given they will be passed to the PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
((node (ewoc--node-nth dll 1))
@@ -428,7 +429,7 @@ ARGS are given they will be passed to the PREDICATE."
(defun ewoc-locate (ewoc &optional pos guess)
"Return the node that POS (a buffer position) is within.
POS may be a marker or an integer. It defaults to point.
-GUESS should be a node that it is likely that POS is near.
+GUESS should be a node that it is likely to be near POS.
If POS points before the first element, the first node is returned.
If POS points after the last element, the last node is returned.
@@ -497,7 +498,7 @@ If the EWOC is empty, nil is returned."
(defun ewoc-invalidate (ewoc &rest nodes)
"Refresh some elements.
-The pretty-printer that for EWOC will be called for all NODES."
+The pretty-printer set for EWOC will be called for all NODES."
(ewoc--set-buffer-bind-dll ewoc
(dolist (node nodes)
(ewoc--refresh-node (ewoc--pretty-printer ewoc) node))))
@@ -564,13 +565,13 @@ number of elements needs to be refreshed."
(defun ewoc-collect (ewoc predicate &rest args)
"Select elements from EWOC using PREDICATE.
Return a list of all selected data elements.
-PREDICATE is a function that takes a data element as its first argument.
-The elements on the returned list will appear in the same order as in
-the buffer. You should not rely on in which order PREDICATE is
-called.
-Note that the buffer the EWOC is displayed in is current-buffer
-when PREDICATE is called. If PREDICATE must restore current-buffer if
-it changes it.
+PREDICATE is a function that takes a data element as its first
+argument. The elements on the returned list will appear in the
+same order as in the buffer. You should not rely on the order of
+calls to PREDICATE.
+Note that the buffer the EWOC is displayed in is the current
+buffer when PREDICATE is called. PREDICATE must restore it if it
+changes it.
If more than two arguments are given the
remaining arguments will be passed to PREDICATE."
(ewoc--set-buffer-bind-dll-let* ewoc
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 5a7cd1093c4..54efd14b358 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -1,6 +1,6 @@
;;; find-func.el --- find the definition of the Emacs Lisp function near point
-;; Copyright (C) 1997, 1999, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2001, 2004 Free Software Foundation, Inc.
;; Author: Jens Petersen <petersen@kurims.kyoto-u.ac.jp>
;; Maintainer: petersen@kurims.kyoto-u.ac.jp
@@ -128,6 +128,40 @@ See the functions `find-function' and `find-variable'."
(append (find-library-suffixes) '("")))
(error "Can't find library %s" library)))
+(defvar find-function-C-source-directory
+ (let ((dir (expand-file-name "src" source-directory)))
+ (when (and (file-directory-p dir) (file-readable-p dir))
+ dir))
+ "Directory where the C source files of Emacs can be found.
+If nil, do not try to find the source code of functions and variables
+defined in C.")
+
+(defun find-function-C-source (fun-or-var file variable-p)
+ "Find the source location where SUBR-OR-VAR is defined in FILE.
+VARIABLE-P should be non-nil for a variable or nil for a subroutine."
+ (unless find-function-C-source-directory
+ (setq find-function-C-source-directory
+ (read-directory-name "Emacs C source dir: " nil nil t)))
+ (setq file (expand-file-name file find-function-C-source-directory))
+ (unless (file-readable-p file)
+ (error "The C source file %s is not available"
+ (file-name-nondirectory file)))
+ (unless variable-p
+ (setq fun-or-var (indirect-function fun-or-var)))
+ (with-current-buffer (find-file-noselect file)
+ (goto-char (point-min))
+ (unless (re-search-forward
+ (if variable-p
+ (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\""
+ (regexp-quote (symbol-name fun-or-var))
+ "\"")
+ (concat "DEFUN[ \t\n]*([ \t\n]*\""
+ (regexp-quote (subr-name fun-or-var))
+ "\""))
+ nil t)
+ (error "Can't find source for %s" fun-or-var))
+ (cons (current-buffer) (match-beginning 0))))
+
;;;###autoload
(defun find-library (library)
"Find the elisp source of LIBRARY."
@@ -149,9 +183,10 @@ If VARIABLE-P is nil, `find-function-regexp' is used, otherwise
(error "Don't know where `%s' is defined" symbol))
;; Some functions are defined as part of the construct
;; that defines something else.
- (while (get symbol 'definition-name)
+ (while (and (symbolp symbol) (get symbol 'definition-name))
(setq symbol (get symbol 'definition-name)))
- (save-match-data
+ (if (string-match "\\`src/\\(.*\\.c\\)\\'" library)
+ (find-function-C-source symbol (match-string 1 library) variable-p)
(if (string-match "\\.el\\(c\\)\\'" library)
(setq library (substring library 0 (match-beginning 1))))
(let* ((filename (find-library-name library)))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index 8cd0fdf0da0..d471ad79538 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -239,6 +239,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(set-keymap-parent emacs-lisp-mode-map lisp-mode-shared-map)
(define-key emacs-lisp-mode-map "\e\t" 'lisp-complete-symbol)
(define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun)
+ (define-key emacs-lisp-mode-map "\e\C-q" 'indent-pp-sexp)
(define-key emacs-lisp-mode-map [menu-bar] (make-sparse-keymap))
(define-key emacs-lisp-mode-map [menu-bar emacs-lisp]
(cons "Emacs-Lisp" map))
@@ -355,6 +356,14 @@ if that value is non-nil."
(setq imenu-case-fold-search t)
(set-syntax-table lisp-mode-syntax-table)
(run-mode-hooks 'lisp-mode-hook))
+(put 'lisp-mode 'find-tag-default-function 'lisp-find-tag-default)
+
+(defun lisp-find-tag-default ()
+ (let ((default (find-tag-default)))
+ (when (stringp default)
+ (if (string-match ":+" default)
+ (substring default (match-end 0))
+ default))))
;; Used in old LispM code.
(defalias 'common-lisp-mode 'lisp-mode)
@@ -369,6 +378,7 @@ if that value is non-nil."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map lisp-mode-shared-map)
(define-key map "\e\C-x" 'eval-defun)
+ (define-key map "\e\C-q" 'indent-pp-sexp)
(define-key map "\e\t" 'lisp-complete-symbol)
(define-key map "\n" 'eval-print-last-sexp)
map)
@@ -448,7 +458,7 @@ alternative printed representations that can be displayed."
"Return a string representing CHAR as a character rather than as an integer.
If CHAR is not a character, return nil."
(and (integerp char)
- (characterp (event-basic-type char))
+ (eventp char)
(let ((c (event-basic-type char)))
(concat
"?"
@@ -460,7 +470,10 @@ If CHAR is not a character, return nil."
(cond
((memq c '(?\; ?\( ?\) ?\{ ?\} ?\[ ?\] ?\" ?\' ?\\)) (string ?\\ c))
((eq c 127) "\\C-?")
- (t (string c)))))))
+ (t
+ (condition-case nil
+ (string c)
+ (error nil))))))))
(defun eval-last-sexp-1 (eval-last-sexp-arg-internal)
"Evaluate sexp before point; print value in minibuffer.
@@ -524,13 +537,12 @@ With argument, print output into current buffer."
(prin1-to-string value)))
(print-length eval-expression-print-length)
(print-level eval-expression-print-level)
- (char-string (prin1-char value))
(beg (point))
end)
(prog1
(prin1 value)
- (if (and (eq standard-output t) char-string)
- (princ (concat " = " char-string)))
+ (let ((str (eval-expression-print-format value)))
+ (if str (princ str)))
(setq end (point))
(when (and (bufferp standard-output)
(or (not (null print-length))
@@ -558,8 +570,9 @@ Interactively, with prefix argument, print output into current buffer."
value)))
(defun eval-defun-1 (form)
- "Change defvar into defconst within FORM.
-Likewise for other constructs as necessary."
+ "Treat some expressions specially.
+Reset the `defvar' and `defcustom' variables to the initial value.
+Reinitialize the face according to the `defface' specification."
;; The code in edebug-defun should be consistent with this, but not
;; the same, since this gets a macroexpended form.
(cond ((not (listp form))
@@ -577,6 +590,13 @@ Likewise for other constructs as necessary."
;; Force variable to be bound.
(set-default (eval (nth 1 form)) (eval (nth 1 (nth 2 form))))
form)
+ ;; `defface' is macroexpanded to `custom-declare-face'.
+ ((eq (car form) 'custom-declare-face)
+ ;; Reset the face.
+ (put (eval (nth 1 form)) 'face-defface-spec nil)
+ (setq face-new-frame-defaults
+ (assq-delete-all (eval (nth 1 form)) face-new-frame-defaults))
+ form)
((eq (car form) 'progn)
(cons 'progn (mapcar 'eval-defun-1 (cdr form))))
(t form)))
@@ -612,7 +632,7 @@ Return the result of evaluation."
(setq beg (point))
(setq form (read (current-buffer)))
(setq end (point)))
- ;; Alter the form if necessary, changing defvar into defconst, etc.
+ ;; Alter the form if necessary.
(setq form (eval-defun-1 (macroexpand form)))
(list beg end standard-output
`(lambda (ignore)
@@ -1084,6 +1104,19 @@ ENDPOS is encountered."
(indent-sexp endmark)
(set-marker endmark nil))))
+(defun indent-pp-sexp (&optional arg)
+ "Indent each line of the list or, with prefix ARG, pretty-printify the list."
+ (interactive "P")
+ (if arg
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (progn (forward-sexp 1) (point)))
+ (pp-buffer)
+ (goto-char (point-max))
+ (if (eq (char-before) ?\n)
+ (delete-char -1)))))
+ (indent-sexp))
+
;;;; Lisp paragraph filling commands.
(defcustom emacs-lisp-docstring-fill-column 65
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el
index e1ed508b865..25fde86cd96 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/emacs-lisp/lisp.el
@@ -175,6 +175,8 @@ open-parenthesis, and point ends up at the beginning of the line.
If variable `beginning-of-defun-function' is non-nil, its value
is called as a function to find the defun's beginning."
(interactive "p")
+ (and (eq this-command 'beginning-of-defun)
+ (or (eq last-command 'beginning-of-defun) (push-mark)))
(and (beginning-of-defun-raw arg)
(progn (beginning-of-line) t)))
@@ -223,6 +225,8 @@ matches the open-parenthesis that starts a defun; see function
If variable `end-of-defun-function' is non-nil, its value
is called as a function to find the defun's end."
(interactive "p")
+ (and (eq this-command 'end-of-defun)
+ (or (eq last-command 'end-of-defun) (push-mark)))
(if (or (null arg) (= arg 0)) (setq arg 1))
(if end-of-defun-function
(if (> arg 0)
@@ -277,15 +281,31 @@ already marked."
(end-of-defun)
(point))))
(t
- ;; Do it in this order for the sake of languages with nested
- ;; functions where several can end at the same place as with
- ;; the offside rule, e.g. Python.
- (push-mark (point))
- (beginning-of-defun)
- (push-mark (point) nil t)
- (end-of-defun)
- (exchange-point-and-mark)
- (re-search-backward "^\n" (- (point) 1) t))))
+ (let ((opoint (point))
+ beg end)
+ (push-mark opoint)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+ (beginning-of-defun)
+ (setq beg (point))
+ (end-of-defun)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (if (> (point) opoint)
+ (progn
+ ;; We got the right defun.
+ (push-mark beg nil t)
+ (goto-char end)
+ (exchange-point-and-mark))
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (push-mark (point) nil t)
+ (beginning-of-defun))
+ (re-search-backward "^\n" (- (point) 1) t)))))
(defun narrow-to-defun (&optional arg)
"Make text outside current defun invisible.
@@ -294,37 +314,112 @@ Optional ARG is ignored."
(interactive)
(save-excursion
(widen)
- ;; Do it in this order for the sake of languages with nested
- ;; functions where several can end at the same place as with the
- ;; offside rule, e.g. Python.
- (beginning-of-defun)
- (let ((beg (point)))
+ (let ((opoint (point))
+ beg end)
+ ;; Try first in this order for the sake of languages with nested
+ ;; functions where several can end at the same place as with
+ ;; the offside rule, e.g. Python.
+ (beginning-of-defun)
+ (setq beg (point))
(end-of-defun)
- (narrow-to-region beg (point)))))
-
-(defun insert-parentheses (arg)
+ (setq end (point))
+ (while (looking-at "^\n")
+ (forward-line 1))
+ (unless (> (point) opoint)
+ ;; beginning-of-defun moved back one defun
+ ;; so we got the wrong one.
+ (goto-char opoint)
+ (end-of-defun)
+ (setq end (point))
+ (beginning-of-defun)
+ (setq beg (point)))
+ (goto-char end)
+ (re-search-backward "^\n" (- (point) 1) t)
+ (narrow-to-region beg end))))
+
+(defvar insert-pair-alist
+ '((?\( ?\)) (?\[ ?\]) (?\{ ?\}) (?\< ?\>) (?\" ?\") (?\' ?\') (?\` ?\'))
+ "Alist of paired characters inserted by `insert-pair'.
+Each element looks like (OPEN-CHAR CLOSE-CHAR) or (COMMAND-CHAR
+OPEN-CHAR CLOSE-CHAR). The characters OPEN-CHAR and CLOSE-CHAR
+of the pair whose key is equal to the last input character with
+or without modifiers, are inserted by `insert-pair'.")
+
+(defun insert-pair (&optional arg open close)
+ "Enclose following ARG sexps in a pair of OPEN and CLOSE characters.
+Leave point after the first character.
+A negative ARG encloses the preceding ARG sexps instead.
+No argument is equivalent to zero: just insert characters
+and leave point between.
+If `parens-require-spaces' is non-nil, this command also inserts a space
+before and after, depending on the surrounding characters.
+If region is active, insert enclosing characters at region boundaries.
+
+If arguments OPEN and CLOSE are nil, the character pair is found
+from the variable `insert-pair-alist' according to the last input
+character with or without modifiers. If no character pair is
+found in the variable `insert-pair-alist', then the last input
+character is inserted ARG times."
+ (interactive "P")
+ (if (not (and open close))
+ (let ((pair (or (assq last-command-char insert-pair-alist)
+ (assq (event-basic-type last-command-event)
+ insert-pair-alist))))
+ (if pair
+ (if (nth 2 pair)
+ (setq open (nth 1 pair) close (nth 2 pair))
+ (setq open (nth 0 pair) close (nth 1 pair))))))
+ (if (and open close)
+ (if (and transient-mark-mode mark-active)
+ (progn
+ (save-excursion (goto-char (region-end)) (insert close))
+ (save-excursion (goto-char (region-beginning)) (insert open)))
+ (if arg (setq arg (prefix-numeric-value arg))
+ (setq arg 0))
+ (cond ((> arg 0) (skip-chars-forward " \t"))
+ ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
+ (and parens-require-spaces
+ (not (bobp))
+ (memq (char-syntax (preceding-char)) (list ?w ?_ (char-syntax close)))
+ (insert " "))
+ (insert open)
+ (save-excursion
+ (or (eq arg 0) (forward-sexp arg))
+ (insert close)
+ (and parens-require-spaces
+ (not (eobp))
+ (memq (char-syntax (following-char)) (list ?w ?_ (char-syntax open)))
+ (insert " "))))
+ (insert-char (event-basic-type last-command-event)
+ (prefix-numeric-value arg))))
+
+(defun insert-parentheses (&optional arg)
"Enclose following ARG sexps in parentheses. Leave point after open-paren.
A negative ARG encloses the preceding ARG sexps instead.
No argument is equivalent to zero: just insert `()' and leave point between.
If `parens-require-spaces' is non-nil, this command also inserts a space
-before and after, depending on the surrounding characters."
+before and after, depending on the surrounding characters.
+If region is active, insert enclosing characters at region boundaries."
(interactive "P")
- (if arg (setq arg (prefix-numeric-value arg))
- (setq arg 0))
- (cond ((> arg 0) (skip-chars-forward " \t"))
- ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
- (and parens-require-spaces
- (not (bobp))
- (memq (char-syntax (preceding-char)) '(?w ?_ ?\) ))
- (insert " "))
- (insert ?\()
- (save-excursion
- (or (eq arg 0) (forward-sexp arg))
- (insert ?\))
- (and parens-require-spaces
- (not (eobp))
- (memq (char-syntax (following-char)) '(?w ?_ ?\( ))
- (insert " "))))
+ (insert-pair arg ?\( ?\)))
+
+(defun delete-pair ()
+ "Delete a pair of characters enclosing the sexp that follows point."
+ (interactive)
+ (save-excursion (forward-sexp 1) (delete-char -1))
+ (delete-char 1))
+
+(defun raise-sexp (&optional arg)
+ "Raise ARG sexps higher up the tree."
+ (interactive "p")
+ (let ((s (if (and transient-mark-mode mark-active)
+ (buffer-substring (region-beginning) (region-end))
+ (buffer-substring
+ (point)
+ (save-excursion (forward-sexp arg) (point))))))
+ (backward-up-list 1)
+ (delete-region (point) (save-excursion (forward-sexp 1) (point)))
+ (save-excursion (insert s))))
(defun move-past-close-and-reindent ()
"Move past next `)', delete indentation before it, then indent after it."
diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el
index c93868859f0..61d31921e57 100644
--- a/lisp/emacs-lisp/pp.el
+++ b/lisp/emacs-lisp/pp.el
@@ -50,34 +50,40 @@ to make output that `read' can handle, whenever this is possible."
(let ((print-escape-newlines pp-escape-newlines)
(print-quoted t))
(prin1 object (current-buffer)))
- (goto-char (point-min))
- (while (not (eobp))
- ;; (message "%06d" (- (point-max) (point)))
- (cond
- ((condition-case err-var
- (prog1 t (down-list 1))
- (error nil))
- (save-excursion
- (backward-char 1)
- (skip-chars-backward "'`#^")
- (when (and (not (bobp)) (= ?\ (char-before)))
- (delete-char -1)
- (insert "\n"))))
- ((condition-case err-var
- (prog1 t (up-list 1))
- (error nil))
- (while (looking-at "\\s)")
- (forward-char 1))
- (delete-region
- (point)
- (progn (skip-chars-forward " \t") (point)))
- (insert ?\n))
- (t (goto-char (point-max)))))
- (goto-char (point-min))
- (indent-sexp)
+ (pp-buffer)
(buffer-string))
(kill-buffer (current-buffer)))))
+(defun pp-buffer ()
+ "Prettify the current buffer with printed representation of a Lisp object."
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; (message "%06d" (- (point-max) (point)))
+ (cond
+ ((condition-case err-var
+ (prog1 t (down-list 1))
+ (error nil))
+ (save-excursion
+ (backward-char 1)
+ (skip-chars-backward "'`#^")
+ (when (and (not (bobp)) (memq (char-before) '(?\ ?\t ?\n)))
+ (delete-region
+ (point)
+ (progn (skip-chars-backward " \t\n") (point)))
+ (insert "\n"))))
+ ((condition-case err-var
+ (prog1 t (up-list 1))
+ (error nil))
+ (while (looking-at "\\s)")
+ (forward-char 1))
+ (delete-region
+ (point)
+ (progn (skip-chars-forward " \t\n") (point)))
+ (insert ?\n))
+ (t (goto-char (point-max)))))
+ (goto-char (point-min))
+ (indent-sexp))
+
;;;###autoload
(defun pp (object &optional stream)
"Output the pretty-printed representation of OBJECT, any Lisp object.
diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el
index 9c904e6c0bc..83d3649006e 100644
--- a/lisp/emacs-lisp/re-builder.el
+++ b/lisp/emacs-lisp/re-builder.el
@@ -494,7 +494,7 @@ If SUBEXP is non-nil mark only the corresponding sub-expressions."
(defun reb-auto-update (beg end lenold &optional force)
"Called from `after-update-functions' to update the display.
-BEG END and LENOLD are passed in from the hook.
+BEG, END and LENOLD are passed in from the hook.
An actual update is only done if the regexp has changed or if the
optional fourth argument FORCE is non-nil."
(let ((prev-valid reb-valid-string)
diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el
index 6656cf5ed3c..d4a10104eea 100644
--- a/lisp/emacs-lisp/rx.el
+++ b/lisp/emacs-lisp/rx.el
@@ -1,6 +1,6 @@
;;; rx.el --- sexp notation for regular expressions
-;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 03, 2004 Free Software Foundation, Inc.
;; Author: Gerd Moellmann <gerd@gnu.org>
;; Maintainer: FSF
@@ -32,6 +32,22 @@
;; from the bugs mentioned in the commentary section of Sregex, and
;; uses a nicer syntax (IMHO, of course :-).
+;; This significantly extended version of the original, is almost
+;; compatible with Sregex. The only incompatibility I (fx) know of is
+;; that the `repeat' form can't have multiple regexp args.
+
+;; Now alternative forms are provided for a degree of compatibility
+;; with Shivers' attempted definitive SRE notation
+;; <URL:http://www.ai.mit.edu/~/shivers/sre.txt>. SRE forms not
+;; catered for include: dsm, uncase, w/case, w/nocase, ,@<exp>,
+;; ,<exp>, (word ...), word+, posix-string, and character class forms.
+;; Some forms are inconsistent with SRE, either for historical reasons
+;; or because of the implementation -- simple translation into Emacs
+;; regexp strings. These include: any, word. Also, case-sensitivity
+;; and greediness are controlled by variables external to the regexp,
+;; and you need to feed the forms to the `posix-' functions to get
+;; SRE's POSIX semantics. There are probably more difficulties.
+
;; Rx translates a sexp notation for regular expressions into the
;; usual string notation. The translation can be done at compile-time
;; by using the `rx' macro. It can be done at run-time by calling
@@ -94,62 +110,103 @@
;;; Code:
-
(defconst rx-constituents
'((and . (rx-and 1 nil))
+ (seq . and) ; SRE
+ (: . and) ; SRE
+ (sequence . and) ; sregex
(or . (rx-or 1 nil))
+ (| . or) ; SRE
(not-newline . ".")
+ (nonl . not-newline) ; SRE
(anything . ".\\|\n")
- (any . (rx-any 1 1 rx-check-any))
+ (any . (rx-any 1 nil rx-check-any)) ; inconsistent with SRE
(in . any)
+ (char . any) ; sregex
+ (not-char . (rx-not-char 1 nil rx-check-any)) ; sregex
(not . (rx-not 1 1 rx-check-not))
+ ;; Partially consistent with sregex, whose `repeat' is like our
+ ;; `**'. (`repeat' with optional max arg and multiple sexp forms
+ ;; is ambiguous.)
(repeat . (rx-repeat 2 3))
- (submatch . (rx-submatch 1 nil))
+ (= . (rx-= 2 nil)) ; SRE
+ (>= . (rx->= 2 nil)) ; SRE
+ (** . (rx-** 2 nil)) ; SRE
+ (submatch . (rx-submatch 1 nil)) ; SRE
(group . submatch)
- (zero-or-more . (rx-kleene 1 1))
- (one-or-more . (rx-kleene 1 1))
- (zero-or-one . (rx-kleene 1 1))
- (\? . zero-or-one)
+ (zero-or-more . (rx-kleene 1 nil))
+ (one-or-more . (rx-kleene 1 nil))
+ (zero-or-one . (rx-kleene 1 nil))
+ (\? . zero-or-one) ; SRE
(\?? . zero-or-one)
- (* . zero-or-more)
+ (* . zero-or-more) ; SRE
(*? . zero-or-more)
(0+ . zero-or-more)
- (+ . one-or-more)
+ (+ . one-or-more) ; SRE
(+? . one-or-more)
(1+ . one-or-more)
(optional . zero-or-one)
+ (opt . zero-or-one) ; sregex
(minimal-match . (rx-greedy 1 1))
(maximal-match . (rx-greedy 1 1))
(backref . (rx-backref 1 1 rx-check-backref))
(line-start . "^")
+ (bol . line-start) ; SRE
(line-end . "$")
+ (eol . line-end) ; SRE
(string-start . "\\`")
+ (bos . string-start) ; SRE
+ (bot . string-start) ; sregex
(string-end . "\\'")
+ (eos . string-end) ; SRE
+ (eot . string-end) ; sregex
(buffer-start . "\\`")
(buffer-end . "\\'")
(point . "\\=")
(word-start . "\\<")
+ (bow . word-start) ; SRE
(word-end . "\\>")
+ (eow . word-end) ; SRE
(word-boundary . "\\b")
+ (not-word-boundary . "\\B") ; sregex
(syntax . (rx-syntax 1 1))
+ (not-syntax . (rx-not-syntax 1 1)) ; sregex
(category . (rx-category 1 1 rx-check-category))
(eval . (rx-eval 1 1))
(regexp . (rx-regexp 1 1 stringp))
(digit . "[[:digit:]]")
- (control . "[[:cntrl:]]")
- (hex-digit . "[[:xdigit:]]")
- (blank . "[[:blank:]]")
- (graphic . "[[:graph:]]")
- (printing . "[[:print:]]")
- (alphanumeric . "[[:alnum:]]")
+ (numeric . digit) ; SRE
+ (num . digit) ; SRE
+ (control . "[[:cntrl:]]") ; SRE
+ (cntrl . control) ; SRE
+ (hex-digit . "[[:xdigit:]]") ; SRE
+ (hex . hex-digit) ; SRE
+ (xdigit . hex-digit) ; SRE
+ (blank . "[[:blank:]]") ; SRE
+ (graphic . "[[:graph:]]") ; SRE
+ (graph . graphic) ; SRE
+ (printing . "[[:print:]]") ; SRE
+ (print . printing) ; SRE
+ (alphanumeric . "[[:alnum:]]") ; SRE
+ (alnum . alphanumeric) ; SRE
(letter . "[[:alpha:]]")
- (ascii . "[[:ascii:]]")
+ (alphabetic . letter) ; SRE
+ (alpha . letter) ; SRE
+ (ascii . "[[:ascii:]]") ; SRE
(nonascii . "[[:nonascii:]]")
- (lower . "[[:lower:]]")
- (punctuation . "[[:punct:]]")
- (space . "[[:space:]]")
- (upper . "[[:upper:]]")
- (word . "[[:word:]]"))
+ (lower . "[[:lower:]]") ; SRE
+ (lower-case . lower) ; SRE
+ (punctuation . "[[:punct:]]") ; SRE
+ (punct . punctuation) ; SRE
+ (space . "[[:space:]]") ; SRE
+ (whitespace . space) ; SRE
+ (white . space) ; SRE
+ (upper . "[[:upper:]]") ; SRE
+ (upper-case . upper) ; SRE
+ (word . "[[:word:]]") ; inconsistent with SRE
+ (wordchar . word) ; sregex
+ (not-wordchar . "[^[:word:]]") ; sregex (use \\W?)
+ )
"Alist of sexp form regexp constituents.
Each element of the alist has the form (SYMBOL . DEFN).
SYMBOL is a valid constituent of sexp regular expressions.
@@ -252,6 +309,8 @@ See also `rx-constituents'."
(defun rx-check (form)
"Check FORM according to its car's parsing info."
+ (unless (listp form)
+ (error "rx `%s' needs argument(s)" form))
(let* ((rx (rx-info (car form)))
(nargs (1- (length form)))
(min-args (nth 1 rx))
@@ -297,53 +356,61 @@ FORM is of the form `(and FORM1 ...)'."
"\\)")))
-(defun rx-quote-for-set (string)
- "Transform STRING for use in a character set.
-If STRING contains a `]', move it to the front.
-If STRING starts with a '^', move it to the end."
- (when (string-match "\\`\\(\\(?:.\\|\n\\)+\\)\\]\\(\\(?:.\\|\n\\)\\)*\\'"
- string)
- (setq string (concat "]" (match-string 1 string)
- (match-string 2 string))))
- (when (string-match "\\`^\\(\\(?:.\\|\n\\)+\\)\\'" string)
- (setq string (concat (substring string 1) "^")))
- string)
-
+(defvar rx-bracket) ; dynamically bound in `rx-any'
(defun rx-check-any (arg)
"Check arg ARG for Rx `any'."
- (cond ((integerp arg) t)
- ((and (stringp arg) (zerop (length arg)))
- (error "String arg for rx `any' must not be empty"))
- ((stringp arg) t)
- (t
- (error "rx `any' requires string or character arg"))))
-
+ (if (integerp arg)
+ (setq arg (string arg)))
+ (when (stringp arg)
+ (if (zerop (length arg))
+ (error "String arg for Rx `any' must not be empty"))
+ ;; Quote ^ at start; don't bother to check whether this is first arg.
+ (if (eq ?^ (aref arg 0))
+ (setq arg (concat "\\" arg)))
+ ;; Remove ] and set flag for adding it to start of overall result.
+ (when (string-match "]" arg)
+ (setq arg (replace-regexp-in-string "]" "" arg)
+ rx-bracket "]")))
+ (when (symbolp arg)
+ (let ((translation (condition-case nil
+ (rx-to-string arg 'no-group)
+ (error nil))))
+ (unless translation (error "Invalid char class `%s' in Rx `any'" arg))
+ (setq arg (substring translation 1 -1)))) ; strip outer brackets
+ ;; sregex compatibility
+ (when (and (integerp (car-safe arg))
+ (integerp (cdr-safe arg)))
+ (setq arg (string (car arg) ?- (cdr arg))))
+ (unless (stringp arg)
+ (error "rx `any' requires string, character, char pair or char class args"))
+ arg)
(defun rx-any (form)
- "Parse and produce code from FORM, which is `(any STRING)'.
-STRING is optional. If it is omitted, build a regexp that
-matches anything."
+ "Parse and produce code from FORM, which is `(any ARG ...)'.
+ARG is optional."
(rx-check form)
- (let ((arg (cadr form)))
- (cond ((integerp arg)
- (char-to-string arg))
- ((= (length arg) 1)
- arg)
- (t
- (concat "[" (rx-quote-for-set (cadr form)) "]")))))
+ (let* ((rx-bracket nil)
+ (args (mapcar #'rx-check-any (cdr form)))) ; side-effects `rx-bracket'
+ ;; If there was a ?- in the form, move it to the front to avoid
+ ;; accidental range.
+ (if (member "-" args)
+ (setq args (cons "-" (delete "-" args))))
+ (apply #'concat "[" rx-bracket (append args '("]")))))
(defun rx-check-not (arg)
"Check arg ARG for Rx `not'."
- (unless (or (memq form
- '(digit control hex-digit blank graphic printing
- alphanumeric letter ascii nonascii lower
- punctuation space upper word))
- (and (consp form)
- (memq (car form) '(not any in syntax category:))))
- (error "rx `not' syntax error: %s" form))
- t)
+ (unless (or (and (symbolp arg)
+ (string-match "\\`\\[\\[:[-a-z]:]]\\'"
+ (condition-case nil
+ (rx-to-string arg 'no-group)
+ (error ""))))
+ (eq arg 'word-boundary)
+ (and (consp arg)
+ (memq (car arg) '(not any in syntax category))))
+ (error "rx `not' syntax error: %s" arg))
+ t)
(defun rx-not (form)
@@ -355,24 +422,67 @@ matches anything."
(if (= (length result) 4)
(substring result 2 3)
(concat "[" (substring result 2))))
- ((string-match "\\`\\[" result)
+ ((eq ?\[ (aref result 0))
(concat "[^" (substring result 1)))
- ((string-match "\\`\\\\s." result)
- (concat "\\S" (substring result 2)))
- ((string-match "\\`\\\\S." result)
- (concat "\\s" (substring result 2)))
- ((string-match "\\`\\\\c." result)
- (concat "\\C" (substring result 2)))
- ((string-match "\\`\\\\C." result)
- (concat "\\c" (substring result 2)))
- ((string-match "\\`\\\\B" result)
- (concat "\\b" (substring result 2)))
- ((string-match "\\`\\\\b" result)
- (concat "\\B" (substring result 2)))
+ ((string-match "\\`\\\\[scb]" result)
+ (concat (capitalize (substring result 0 2)) (substring result 2)))
(t
(concat "[^" result "]")))))
+(defun rx-not-char (form)
+ "Parse and produce code from FORM. FORM is `(not-char ...)'."
+ (rx-check form)
+ (rx-not `(not (in ,@(cdr form)))))
+
+
+(defun rx-not-syntax (form)
+ "Parse and produce code from FORM. FORM is `(not-syntax SYNTAX)'."
+ (rx-check form)
+ (rx-not `(not (syntax ,@(cdr form)))))
+
+
+(defun rx-trans-forms (form &optional skip)
+ "If FORM's length is greater than two, transform it to length two.
+A form (HEAD REST ...) becomes (HEAD (and REST ...)).
+If SKIP is non-nil, allow that number of items after the head, i.e.
+`(= N REST ...)' becomes `(= N (and REST ...))' if SKIP is 1."
+ (unless skip (setq skip 0))
+ (let ((tail (nthcdr (1+ skip) form)))
+ (if (= (length tail) 1)
+ form
+ (let ((form (copy-sequence form)))
+ (setcdr (nthcdr skip form) (list (cons 'and tail)))
+ form))))
+
+
+(defun rx-= (form)
+ "Parse and produce code from FORM `(= N ...)'."
+ (rx-check form)
+ (setq form (rx-trans-forms form 1))
+ (unless (and (integerp (nth 1 form))
+ (> (nth 1 form) 0))
+ (error "rx `=' requires positive integer first arg"))
+ (format "%s\\{%d\\}" (rx-to-string (nth 2 form)) (nth 1 form)))
+
+
+(defun rx->= (form)
+ "Parse and produce code from FORM `(>= N ...)'."
+ (rx-check form)
+ (setq form (rx-trans-forms form 1))
+ (unless (and (integerp (nth 1 form))
+ (> (nth 1 form) 0))
+ (error "rx `>=' requires positive integer first arg"))
+ (format "%s\\{%d,\\}" (rx-to-string (nth 2 form)) (nth 1 form)))
+
+
+(defun rx-** (form)
+ "Parse and produce code from FORM `(** N M ...)'."
+ (rx-check form)
+ (setq form (cons 'repeat (cdr (rx-trans-forms form 2))))
+ (rx-to-string form))
+
+
(defun rx-repeat (form)
"Parse and produce code from FORM.
FORM is either `(repeat N FORM1)' or `(repeat N M FORM1)'."
@@ -419,6 +529,7 @@ If OP is one of `*?', `+?', `??', produce a non-greedy regexp.
If OP is anything else, produce a greedy regexp if `rx-greedy-flag'
is non-nil."
(rx-check form)
+ (setq form (rx-trans-forms form))
(let ((suffix (cond ((memq (car form) '(* + ? )) "")
((memq (car form) '(*? +? ??)) "?")
(rx-greedy-flag "")
@@ -468,9 +579,15 @@ of all atomic regexps."
(defun rx-syntax (form)
"Parse and produce code from FORM, which is `(syntax SYMBOL)'."
(rx-check form)
- (let ((syntax (assq (cadr form) rx-syntax)))
+ (let* ((sym (cadr form))
+ (syntax (assq sym rx-syntax)))
(unless syntax
- (error "Unknown rx syntax `%s'" (cadr form)))
+ ;; Try sregex compatibility.
+ (let ((name (symbol-name sym)))
+ (if (= 1 (length name))
+ (setq syntax (rassq (aref name 0) rx-syntax))))
+ (unless syntax
+ (error "Unknown rx syntax `%s'" (cadr form))))
(format "\\s%c" (cdr syntax))))
@@ -483,7 +600,7 @@ of all atomic regexps."
(defun rx-category (form)
- "Parse and produce code from FORM, which is `(category SYMBOL ...)'."
+ "Parse and produce code from FORM, which is `(category SYMBOL)'."
(rx-check form)
(let ((char (if (integerp (cadr form))
(cadr form)
@@ -543,8 +660,9 @@ NO-GROUP non-nil means don't put shy groups around the result."
;;;###autoload
-(defmacro rx (regexp)
- "Translate a regular expression REGEXP in sexp form to a regexp string.
+(defmacro rx (&rest regexps)
+ "Translate regular expressions REGEXPS in sexp form to a regexp string.
+REGEXPS is a non-empty sequence of forms of the sort listed below.
See also `rx-to-string' for how to do such a translation at run-time.
The following are valid subforms of regular expressions in sexp
@@ -556,53 +674,58 @@ STRING
CHAR
matches character CHAR literally.
-`not-newline'
+`not-newline', `nonl'
matches any character except a newline.
.
`anything'
matches any character
-`(any SET)'
- matches any character in SET. SET may be a character or string.
+`(any SET ...)'
+`(in SET ...)'
+`(char SET ...)'
+ matches any character in SET .... SET may be a character or string.
Ranges of characters can be specified as `A-Z' in strings.
+ Ranges may also be specified as conses like `(?A . ?Z)'.
-'(in SET)'
- like `any'.
+ SET may also be the name of a character class: `digit',
+ `control', `hex-digit', `blank', `graph', `print', `alnum',
+ `alpha', `ascii', `nonascii', `lower', `punct', `space', `upper',
+ `word', or one of their synonyms.
-`(not (any SET))'
- matches any character not in SET
+`(not (any SET ...))'
+ matches any character not in SET ...
-`line-start'
+`line-start', `bol'
matches the empty string, but only at the beginning of a line
in the text being matched
-`line-end'
+`line-end', `eol'
is similar to `line-start' but matches only at the end of a line
-`string-start'
+`string-start', `bos', `bot'
matches the empty string, but only at the beginning of the
string being matched against.
-`string-end'
+`string-end', `eos', `eot'
matches the empty string, but only at the end of the
string being matched against.
`buffer-start'
matches the empty string, but only at the beginning of the
- buffer being matched against.
+ buffer being matched against. Actually equivalent to `string-start'.
`buffer-end'
matches the empty string, but only at the end of the
- buffer being matched against.
+ buffer being matched against. Actually equivalent to `string-end'.
`point'
matches the empty string, but only at point.
-`word-start'
+`word-start', `bow'
matches the empty string, but only at the beginning or end of a
word.
-`word-end'
+`word-end', `eow'
matches the empty string, but only at the end of a word.
`word-boundary'
@@ -610,34 +733,35 @@ CHAR
word.
`(not word-boundary)'
+`not-word-boundary'
matches the empty string, but not at the beginning or end of a
word.
-`digit'
+`digit', `numeric', `num'
matches 0 through 9.
-`control'
+`control', `cntrl'
matches ASCII control characters.
-`hex-digit'
+`hex-digit', `hex', `xdigit'
matches 0 through 9, a through f and A through F.
`blank'
matches space and tab only.
-`graphic'
+`graphic', `graph'
matches graphic characters--everything except ASCII control chars,
space, and DEL.
-`printing'
+`printing', `print'
matches printing characters--everything except ASCII control chars
and DEL.
-`alphanumeric'
+`alphanumeric', `alnum'
matches letters and digits. (But at present, for multibyte characters,
it matches anything that has word syntax.)
-`letter'
+`letter', `alphabetic', `alpha'
matches letters. (But at present, for multibyte characters,
it matches anything that has word syntax.)
@@ -647,25 +771,29 @@ CHAR
`nonascii'
matches non-ASCII (multibyte) characters.
-`lower'
+`lower', `lower-case'
matches anything lower-case.
-`upper'
+`upper', `upper-case'
matches anything upper-case.
-`punctuation'
+`punctuation', `punct'
matches punctuation. (But at present, for multibyte characters,
it matches anything that has non-word syntax.)
-`space'
+`space', `whitespace', `white'
matches anything that has whitespace syntax.
-`word'
+`word', `wordchar'
matches anything that has word syntax.
+`not-wordchar'
+ matches anything that has non-word syntax.
+
`(syntax SYNTAX)'
matches a character with syntax SYNTAX. SYNTAX must be one
- of the following symbols.
+ of the following symbols, or a symbol corresponding to the syntax
+ character, e.g. `\\.' for `\\s.'.
`whitespace' (\\s- in string notation)
`punctuation' (\\s.)
@@ -684,7 +812,7 @@ CHAR
`comment-delimiter' (\\s!)
`(not (syntax SYNTAX))'
- matches a character that has not syntax SYNTAX.
+ matches a character that doesn't have syntax SYNTAX.
`(category CATEGORY)'
matches a character with category CATEGORY. CATEGORY must be
@@ -710,7 +838,7 @@ CHAR
`japanese-katakana-two-byte' (\\cK)
`korean-hangul-two-byte' (\\cN)
`cyrillic-two-byte' (\\cY)
- `combining-diacritic' (\\c^)
+ `combining-diacritic' (\\c^)
`ascii' (\\ca)
`arabic' (\\cb)
`chinese' (\\cc)
@@ -731,12 +859,16 @@ CHAR
`can-break' (\\c|)
`(not (category CATEGORY))'
- matches a character that has not category CATEGORY.
+ matches a character that doesn't have category CATEGORY.
`(and SEXP1 SEXP2 ...)'
+`(: SEXP1 SEXP2 ...)'
+`(seq SEXP1 SEXP2 ...)'
+`(sequence SEXP1 SEXP2 ...)'
matches what SEXP1 matches, followed by what SEXP2 matches, etc.
`(submatch SEXP1 SEXP2 ...)'
+`(group SEXP1 SEXP2 ...)'
like `and', but makes the match accessible with `match-end',
`match-beginning', and `match-string'.
@@ -744,6 +876,7 @@ CHAR
another name for `submatch'.
`(or SEXP1 SEXP2 ...)'
+`(| SEXP1 SEXP2 ...)'
matches anything that matches SEXP1 or SEXP2, etc. If all
args are strings, use `regexp-opt' to optimize the resulting
regular expression.
@@ -757,47 +890,55 @@ CHAR
`(maximal-match SEXP)'
produce a greedy regexp for SEXP. This is the default.
-`(zero-or-more SEXP)'
- matches zero or more occurrences of what SEXP matches.
-
-`(0+ SEXP)'
- like `zero-or-more'.
+Below, `SEXP ...' represents a sequence of regexp forms, treated as if
+enclosed in `(and ...)'.
-`(* SEXP)'
- like `zero-or-more', but always produces a greedy regexp.
+`(zero-or-more SEXP ...)'
+`(0+ SEXP ...)'
+ matches zero or more occurrences of what SEXP ... matches.
-`(*? SEXP)'
- like `zero-or-more', but always produces a non-greedy regexp.
+`(* SEXP ...)'
+ like `zero-or-more', but always produces a greedy regexp, independent
+ of `rx-greedy-flag'.
-`(one-or-more SEXP)'
- matches one or more occurrences of A.
+`(*? SEXP ...)'
+ like `zero-or-more', but always produces a non-greedy regexp,
+ independent of `rx-greedy-flag'.
-`(1+ SEXP)'
- like `one-or-more'.
+`(one-or-more SEXP ...)'
+`(1+ SEXP ...)'
+ matches one or more occurrences of SEXP ...
-`(+ SEXP)'
+`(+ SEXP ...)'
like `one-or-more', but always produces a greedy regexp.
-`(+? SEXP)'
+`(+? SEXP ...)'
like `one-or-more', but always produces a non-greedy regexp.
-`(zero-or-one SEXP)'
+`(zero-or-one SEXP ...)'
+`(optional SEXP ...)'
+`(opt SEXP ...)'
matches zero or one occurrences of A.
-`(optional SEXP)'
- like `zero-or-one'.
-
-`(? SEXP)'
+`(? SEXP ...)'
like `zero-or-one', but always produces a greedy regexp.
-`(?? SEXP)'
+`(?? SEXP ...)'
like `zero-or-one', but always produces a non-greedy regexp.
`(repeat N SEXP)'
- matches N occurrences of what SEXP matches.
+`(= N SEXP ...)'
+ matches N occurrences.
+
+`(>= N SEXP ...)'
+ matches N or more occurrences.
`(repeat N M SEXP)'
- matches N to M occurrences of what SEXP matches.
+`(** N M SEXP ...)'
+ matches N to M occurrences.
+
+`(backref N)'
+ matches what was matched previously by submatch N.
`(backref N)'
matches what was matched previously by submatch N.
@@ -811,9 +952,21 @@ CHAR
`(regexp REGEXP)'
include REGEXP in string notation in the result."
-
- (rx-to-string regexp))
-
+ (cond ((null regexps)
+ (error "No regexp"))
+ ((cdr regexps)
+ (rx-to-string `(and ,@regexps) t))
+ (t
+ (rx-to-string (car regexps) t))))
+
+;; ;; sregex.el replacement
+
+;; ;;;###autoload (provide 'sregex)
+;; ;;;###autoload (autoload 'sregex "rx")
+;; (defalias 'sregex 'rx-to-string)
+;; ;;;###autoload (autoload 'sregexq "rx" nil nil 'macro)
+;; (defalias 'sregexq 'rx)
+
(provide 'rx)
;;; arch-tag: 12d01a63-0008-42bb-ab8c-1c7d63be370b
diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el
index 4ab2ac8e0d4..336a1ff82d0 100644
--- a/lisp/emacs-lisp/timer.el
+++ b/lisp/emacs-lisp/timer.el
@@ -161,7 +161,7 @@ fire repeatedly that many seconds apart."
(aset timer 6 args)
timer)
-(defun timer-activate (timer)
+(defun timer-activate (timer &optional triggered-p)
"Put TIMER on the list of active timers."
(if (and (timerp timer)
(integerp (aref timer 1))
@@ -184,7 +184,7 @@ fire repeatedly that many seconds apart."
(if last
(setcdr last (cons timer timers))
(setq timer-list (cons timer timers)))
- (aset timer 0 nil)
+ (aset timer 0 triggered-p)
(aset timer 7 nil)
nil)
(error "Invalid or uninitialized timer")))
@@ -270,7 +270,7 @@ This function is called, by name, directly by the C code."
(setq timer-event-last timer)
(let ((inhibit-quit t))
(if (timerp timer)
- (progn
+ (let (retrigger)
;; Delete from queue.
(cancel-timer timer)
;; Re-schedule if requested.
@@ -287,13 +287,16 @@ This function is called, by name, directly by the C code."
(aref timer 4))))
(if (> repeats timer-max-repeats)
(timer-inc-time timer (* (aref timer 4) repeats)))))
- (timer-activate timer)))
+ (timer-activate timer t)
+ (setq retrigger t)))
;; Run handler.
;; We do this after rescheduling so that the handler function
;; can cancel its own timer successfully with cancel-timer.
(condition-case nil
(apply (aref timer 5) (aref timer 6))
- (error nil)))
+ (error nil))
+ (if retrigger
+ (aset timer 0 nil)))
(error "Bogus timer event"))))
;; This function is incompatible with the one in levents.el.
diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el
index 24f95ec21ea..51b47b104d0 100644
--- a/lisp/emulation/cua-base.el
+++ b/lisp/emulation/cua-base.el
@@ -1,6 +1,6 @@
;;; cua-base.el --- emulate CUA key bindings
-;; Copyright (C) 1997,98,99,200,01,02,03 Free Software Foundation, Inc.
+;; Copyright (C) 1997,98,99,200,01,02,03,04 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulation convenience cua
@@ -413,29 +413,101 @@ Can be toggled by [M-p] while the rectangle is active,"
"red")
"Normal (non-overwrite) cursor color.
Also used to indicate that rectangle padding is not in effect.
-Default is to load cursor color from initial or default frame parameters."
+Default is to load cursor color from initial or default frame parameters.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected. If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
+then only the `cursor-type' property will be affected. If the value is
+a cons (TYPE . COLOR), then both properties are affected."
:initialize 'custom-initialize-default
- :type 'color
+ :type '(choice
+ (color :tag "Color")
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (cons :tag "Color and Type"
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (color :tag "Color")))
:group 'cua)
(defcustom cua-read-only-cursor-color "darkgreen"
"*Cursor color used in read-only buffers, if non-nil.
-Only used when `cua-enable-cursor-indications' is non-nil."
- :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected. If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
+then only the `cursor-type' property will be affected. If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+ :type '(choice
+ (color :tag "Color")
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (cons :tag "Color and Type"
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (color :tag "Color")))
:group 'cua)
(defcustom cua-overwrite-cursor-color "yellow"
"*Cursor color used when overwrite mode is set, if non-nil.
Also used to indicate that rectangle padding is in effect.
-Only used when `cua-enable-cursor-indications' is non-nil."
- :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected. If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
+then only the `cursor-type' property will be affected. If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+ :type '(choice
+ (color :tag "Color")
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (cons :tag "Color and Type"
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (color :tag "Color")))
:group 'cua)
(defcustom cua-global-mark-cursor-color "cyan"
"*Indication for active global mark.
Will change cursor color to specified color if string.
-Only used when `cua-enable-cursor-indications' is non-nil."
- :type 'color
+Only used when `cua-enable-cursor-indications' is non-nil.
+
+If the value is a COLOR name, then only the `cursor-color' attribute will be
+affected. If the value is a cursor TYPE (one of: box, hollow, bar, or hbar),
+then only the `cursor-type' property will be affected. If the value is
+a cons (TYPE . COLOR), then both properties are affected."
+ :type '(choice
+ (color :tag "Color")
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (cons :tag "Color and Type"
+ (choice :tag "Type"
+ (const :tag "Filled box" box)
+ (const :tag "Vertical bar" bar)
+ (const :tag "Horisontal bar" hbar)
+ (const :tag "Hollow box" hollow))
+ (color :tag "Color")))
:group 'cua)
@@ -893,7 +965,7 @@ With a double \\[universal-argument] prefix argument, unconditionally set mark."
forward-word backward-word
end-of-line beginning-of-line
end-of-buffer beginning-of-buffer
- scroll-up scroll-down
+ scroll-up scroll-down cua-scroll-up cua-scroll-down
forward-sentence backward-sentence
forward-paragraph backward-paragraph)
"List of standard movement commands.
@@ -903,26 +975,72 @@ Extra commands should be added to `cua-movement-commands'")
"User may add additional movement commands to this list.")
+;;; Scrolling commands which does not signal errors at top/bottom
+;;; of buffer at first key-press (instead moves to top/bottom
+;;; of buffer).
+
+(defun cua-scroll-up (&optional arg)
+ "Scroll text of current window upward ARG lines; or near full screen if no ARG.
+If window cannot be scrolled further, move cursor to bottom line instead.
+A near full screen is `next-screen-context-lines' less than a full screen.
+Negative ARG means scroll downward.
+If ARG is the atom `-', scroll downward by nearly full screen."
+ (interactive "P")
+ (cond
+ ((eq arg '-) (cua-scroll-down nil))
+ ((< (prefix-numeric-value arg) 0)
+ (cua-scroll-down (- (prefix-numeric-value arg))))
+ ((eobp)
+ (scroll-up arg)) ; signal error
+ (t
+ (condition-case nil
+ (scroll-up arg)
+ (end-of-buffer (goto-char (point-max)))))))
+
+(defun cua-scroll-down (&optional arg)
+ "Scroll text of current window downward ARG lines; or near full screen if no ARG.
+If window cannot be scrolled further, move cursor to top line instead.
+A near full screen is `next-screen-context-lines' less than a full screen.
+Negative ARG means scroll upward.
+If ARG is the atom `-', scroll upward by nearly full screen."
+ (interactive "P")
+ (cond
+ ((eq arg '-) (cua-scroll-up nil))
+ ((< (prefix-numeric-value arg) 0)
+ (cua-scroll-up (- (prefix-numeric-value arg))))
+ ((bobp)
+ (scroll-down arg)) ; signal error
+ (t
+ (condition-case nil
+ (scroll-down arg)
+ (beginning-of-buffer (goto-char (point-min)))))))
+
;;; Cursor indications
(defun cua--update-indications ()
- (let ((cursor
- (cond
- ((and cua--global-mark-active
- (stringp cua-global-mark-cursor-color))
- cua-global-mark-cursor-color)
- ((and buffer-read-only
- (stringp cua-read-only-cursor-color))
- cua-read-only-cursor-color)
- ((and (stringp cua-overwrite-cursor-color)
- (or overwrite-mode
- (and cua--rectangle (cua--rectangle-padding))))
- cua-overwrite-cursor-color)
- (t cua-normal-cursor-color))))
- (if (and cursor
- (not (equal cursor (frame-parameter nil 'cursor-color))))
- (set-cursor-color cursor))
- cursor))
+ (let* ((cursor
+ (cond
+ ((and cua--global-mark-active
+ cua-global-mark-cursor-color)
+ cua-global-mark-cursor-color)
+ ((and buffer-read-only
+ cua-read-only-cursor-color)
+ cua-read-only-cursor-color)
+ ((and cua-overwrite-cursor-color
+ (or overwrite-mode
+ (and cua--rectangle (cua--rectangle-padding))))
+ cua-overwrite-cursor-color)
+ (t cua-normal-cursor-color)))
+ (color (if (consp cursor) (cdr cursor) cursor))
+ (type (if (consp cursor) (car cursor) cursor)))
+ (if (and color
+ (stringp color)
+ (not (equal color (frame-parameter nil 'cursor-color))))
+ (set-cursor-color color))
+ (if (and type
+ (symbolp type)
+ (not (eq type default-cursor-type)))
+ (setq default-cursor-type type))))
;;; Pre-command hook
@@ -1108,6 +1226,10 @@ Extra commands should be added to `cua-movement-commands'")
(define-key cua-global-keymap [remap undo] 'cua-undo)
(define-key cua-global-keymap [remap advertised-undo] 'cua-undo)
+ ;; scrolling
+ (define-key cua-global-keymap [remap scroll-up] 'cua-scroll-up)
+ (define-key cua-global-keymap [remap scroll-down] 'cua-scroll-down)
+
(define-key cua--cua-keys-keymap [(control x) timeout] 'kill-region)
(define-key cua--cua-keys-keymap [(control c) timeout] 'copy-region-as-kill)
(define-key cua--cua-keys-keymap [(control z)] 'undo)
@@ -1189,7 +1311,9 @@ paste (in addition to the normal emacs bindings)."
(add-hook 'post-command-hook 'cua--post-command-handler)
(if (and cua-enable-modeline-indications (not (assoc 'cua-mode minor-mode-alist)))
(setq minor-mode-alist (cons '(cua-mode cua--status-string) minor-mode-alist)))
- )
+ (if cua-enable-cursor-indications
+ (cua--update-indications)))
+
(remove-hook 'pre-command-hook 'cua--pre-command-handler)
(remove-hook 'post-command-hook 'cua--post-command-handler))
@@ -1212,6 +1336,7 @@ paste (in addition to the normal emacs bindings)."
(delete-selection-mode -1))
(if (and (boundp 'pc-selection-mode) pc-selection-mode)
(pc-selection-mode -1))
+ (cua--deactivate)
(setq transient-mark-mode (and cua-mode
(if cua-highlight-region-shift-only
(not cua--explicit-region-start)
diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el
index fefd7001029..965fe63bced 100644
--- a/lisp/emulation/cua-rect.el
+++ b/lisp/emulation/cua-rect.el
@@ -1,6 +1,6 @@
;;; cua-rect.el --- CUA unified rectangle support
-;; Copyright (C) 1997-2002 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2002, 2004 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience CUA
@@ -1057,19 +1057,30 @@ The numbers are formatted according to the FORMAT string."
(insert (format fmt first))
(setq first (+ first incr)))))
+(defmacro cua--convert-rectangle-as (command)
+ `(cua--rectangle-operation 'clear nil nil nil
+ '(lambda (s e l r)
+ (,command s e))))
+
(defun cua-upcase-rectangle ()
"Convert the rectangle to upper case."
(interactive)
- (cua--rectangle-operation 'clear nil nil nil
- '(lambda (s e l r)
- (upcase-region s e))))
+ (cua--convert-rectangle-as upcase-region))
(defun cua-downcase-rectangle ()
"Convert the rectangle to lower case."
(interactive)
- (cua--rectangle-operation 'clear nil nil nil
- '(lambda (s e l r)
- (downcase-region s e))))
+ (cua--convert-rectangle-as downcase-region))
+
+(defun cua-upcase-initials-rectangle ()
+ "Convert the rectangle initials to upper case."
+ (interactive)
+ (cua--convert-rectangle-as upcase-initials-region))
+
+(defun cua-capitalize-rectangle ()
+ "Convert the rectangle to proper case."
+ (interactive)
+ (cua--convert-rectangle-as capitalize-region))
;;; Replace/rearrange text in current rectangle
diff --git a/lisp/emulation/pc-select.el b/lisp/emulation/pc-select.el
index c7ea973467f..188e335687c 100644
--- a/lisp/emulation/pc-select.el
+++ b/lisp/emulation/pc-select.el
@@ -61,7 +61,7 @@
;; Eli Barzilay (eli@cs.bgu.ac.il) suggested the sexps functions and
;; keybindings.
;;
-;; Ok, some details about the idea of pc-selection-mode:
+;; Ok, some details about the idea of PC Selection mode:
;;
;; o The standard keys for moving around (right, left, up, down, home, end,
;; prior, next, called "move-keys" from now on) will always de-activate
@@ -114,23 +114,23 @@ This gives mostly Emacs-like behaviour with only the selection keys enabled."
:group 'pc-select)
(defvar pc-select-saved-settings-alist nil
- "The values of the variables before `pc-selection-mode' was toggled on.
-When `pc-selection-mode' is toggled on, it sets quite a few variables
+ "The values of the variables before PC Selection mode was toggled on.
+When PC Selection mode is toggled on, it sets quite a few variables
for its own purposes. This alist holds the original values of the
-variables `pc-selection-mode' had set, so that these variables can be
-restored to their original values when `pc-selection-mode' is toggled off.")
+variables PC Selection mode had set, so that these variables can be
+restored to their original values when PC Selection mode is toggled off.")
(defvar pc-select-map nil
- "The keymap used as the global map when `pc-selection-mode' is on." )
+ "The keymap used as the global map when PC Selection mode is on." )
(defvar pc-select-saved-global-map nil
- "The global map that was in effect when `pc-selection-mode' was toggled on.")
+ "The global map that was in effect when PC Selection mode was toggled on.")
(defvar pc-select-key-bindings-alist nil
- "This alist holds all the key bindings `pc-selection-mode' sets.")
+ "This alist holds all the key bindings PC Selection mode sets.")
(defvar pc-select-default-key-bindings nil
- "These key bindings always get set by `pc-selection-mode'.")
+ "These key bindings always get set by PC Selection mode.")
(unless pc-select-default-key-bindings
(let ((lst
@@ -250,7 +250,7 @@ These key bindings get installed when running in a tty, but only if
(defvar pc-select-old-M-delete-binding nil
"Holds the old mapping of [M-delete] in the `function-key-map'.
This variable holds the value associated with [M-delete] in the
-`function-key-map' before `pc-selection-mode' had changed that
+`function-key-map' before PC Selection mode had changed that
association.")
;;;;
@@ -842,7 +842,7 @@ M-LEFT and M-RIGHT move back or forward one word or sexp, disabling the mark.
S-M-LEFT and S-M-RIGHT move back or forward one word or sexp, leaving the mark
behind. To control whether these keys move word-wise or sexp-wise set the
variable `pc-select-meta-moves-sexps' after loading pc-select.el but before
-turning `pc-selection-mode' on.
+turning PC Selection mode on.
C-DOWN and C-UP move back or forward a paragraph, disabling the mark.
S-C-DOWN and S-C-UP move back or forward a paragraph, leaving the mark behind.
@@ -864,7 +864,7 @@ C-INSERT copies the region into the kill ring (`copy-region-as-kill').
In addition, certain other PC bindings are imitated (to avoid this, set
the variable `pc-select-selection-keys-only' to t after loading pc-select.el
-but before calling `pc-selection-mode'):
+but before calling PC Selection mode):
F6 other-window
DELETE delete-char
@@ -974,7 +974,8 @@ but before calling `pc-selection-mode'):
Change mark behaviour 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.
-You must modify via \\[customize] for this variable to have an effect."
+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
diff --git a/lisp/eshell/.arch-inventory b/lisp/eshell/.arch-inventory
new file mode 100644
index 00000000000..b5d82cdd6fc
--- /dev/null
+++ b/lisp/eshell/.arch-inventory
@@ -0,0 +1,4 @@
+# Generated files
+precious ^(esh-groups)\.el$
+
+# arch-tag: 8dc7bfaa-6ca6-4be0-915a-1e539c3dabfb
diff --git a/lisp/eshell/.gitignore b/lisp/eshell/.gitignore
index 16ccfcc8c0c..e1d7683a723 100644
--- a/lisp/eshell/.gitignore
+++ b/lisp/eshell/.gitignore
@@ -1 +1,14 @@
+COPYING
+FEATURES
+INSTALL
+Makefile
+NEWS
+README
+_darcs
+_pkg.el
+auto-autoloads.el
esh-groups.el
+esh-toggle.el
+eshell-auto.el
+eshell.info
+eshell.texi
diff --git a/lisp/eshell/em-alias.el b/lisp/eshell/em-alias.el
index 0312f9d7ada..02af7531b3f 100644
--- a/lisp/eshell/em-alias.el
+++ b/lisp/eshell/em-alias.el
@@ -1,6 +1,6 @@
;;; em-alias.el --- creation and management of command aliases
-;; Copyright (C) 1999, 2000 Free Software Foundation
+;; Copyright (C) 1999, 2000, 2004 Free Software Foundation
;; Author: John Wiegley <johnw@gnu.org>
@@ -24,6 +24,7 @@
(provide 'em-alias)
(eval-when-compile (require 'esh-maint))
+(require 'eshell)
(defgroup eshell-alias nil
"Command aliases allow for easy definition of alternate commands."
diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el
index 73837c324a5..7b74069454b 100644
--- a/lisp/eshell/em-dirs.el
+++ b/lisp/eshell/em-dirs.el
@@ -1,6 +1,6 @@
;;; em-dirs.el --- directory navigation commands
-;; Copyright (C) 1999, 2000 Free Software Foundation
+;; Copyright (C) 1999, 2000, 2004 Free Software Foundation
;; Author: John Wiegley <johnw@gnu.org>
@@ -24,6 +24,7 @@
(provide 'em-dirs)
(eval-when-compile (require 'esh-maint))
+(require 'eshell)
(defgroup eshell-dirs nil
"Directory navigation involves changing directories, examining the
diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el
index 24447c3e66d..c84962e66b0 100644
--- a/lisp/eshell/em-glob.el
+++ b/lisp/eshell/em-glob.el
@@ -122,10 +122,6 @@ This option slows down recursive glob processing by quite a bit."
:type '(repeat (cons character (choice regexp function)))
:group 'eshell-glob)
-;;; Internal Variables:
-
-(defvar eshell-glob-chars-regexp nil)
-
;;; Functions:
(defun eshell-glob-initialize ()
@@ -134,8 +130,6 @@ This option slows down recursive glob processing by quite a bit."
(when (boundp 'eshell-special-chars-outside-quoting)
(set (make-local-variable 'eshell-special-chars-outside-quoting)
(append eshell-glob-chars-list eshell-special-chars-outside-quoting)))
- (set (make-local-variable 'eshell-glob-chars-regexp)
- (format "[%s]+" (apply 'string eshell-glob-chars-list)))
(add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars t t)
(add-hook 'eshell-pre-rewrite-command-hook
'eshell-no-command-globbing nil t))
@@ -184,6 +178,8 @@ interpretation."
(buffer-substring-no-properties (1- (point)) (1+ end))
(goto-char (1+ end))))))))))
+(defvar eshell-glob-chars-regexp nil)
+
(defun eshell-glob-regexp (pattern)
"Convert glob-pattern PATTERN to a regular expression.
The basic syntax is:
@@ -204,8 +200,11 @@ set to true, then these characters will match themselves in the
resulting regular expression."
(let ((matched-in-pattern 0) ; How much of PATTERN handled
regexp)
- (while (string-match eshell-glob-chars-regexp
- pattern matched-in-pattern)
+ (while (string-match
+ (or eshell-glob-chars-regexp
+ (set (make-local-variable 'eshell-glob-chars-regexp)
+ (format "[%s]+" (apply 'string eshell-glob-chars-list))))
+ pattern matched-in-pattern)
(let* ((op-begin (match-beginning 0))
(op-char (aref pattern op-begin)))
(setq regexp
diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el
index b38c7a519ec..f4bfea798e0 100644
--- a/lisp/eshell/em-hist.el
+++ b/lisp/eshell/em-hist.el
@@ -24,6 +24,7 @@
(provide 'em-hist)
(eval-when-compile (require 'esh-maint))
+(require 'eshell)
(defgroup eshell-hist nil
"This module provides command history management."
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index 8446eb1aa9d..43d3c9c4e5e 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -1,6 +1,6 @@
;;; em-unix.el --- UNIX command aliases
-;; Copyright (C) 1999, 2000, 2001 Free Software Foundation
+;; Copyright (C) 1999, 2000, 2001, 2004 Free Software Foundation
;; Author: John Wiegley <johnw@gnu.org>
@@ -24,6 +24,7 @@
(provide 'em-unix)
(eval-when-compile (require 'esh-maint))
+(require 'eshell)
(defgroup eshell-unix nil
"This module defines many of the more common UNIX utilities as
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 9b4f54ce8bf..477d8b410ec 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -1246,9 +1246,8 @@ be finished later after the completion of an asynchronous subprocess."
(setq program (eshell-search-path name))
(let* ((esym (eshell-find-alias-function name))
(sym (or esym (intern-soft name))))
- (if (and sym (fboundp sym)
- (or esym eshell-prefer-lisp-functions
- (not program)))
+ (if (and (or esym (and sym (fboundp sym)))
+ (or eshell-prefer-lisp-functions (not direct)))
(let ((desc (let ((inhibit-redisplay t))
(save-window-excursion
(prog1
diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el
index 8d1036b736e..d832fa9cd03 100644
--- a/lisp/eshell/esh-io.el
+++ b/lisp/eshell/esh-io.el
@@ -333,22 +333,23 @@ it defaults to `insert'."
(cond
((stringp target)
(let ((redir (assoc target eshell-virtual-targets)))
- (if redir
- (if (nth 2 redir)
- (funcall (nth 1 redir) mode)
- (nth 1 redir))
- (let* ((exists (get-file-buffer target))
- (buf (find-file-noselect target t)))
- (with-current-buffer buf
- (if buffer-read-only
- (error "Cannot write to read-only file `%s'" target))
- (set (make-local-variable 'eshell-output-file-buffer)
- (if (eq exists buf) 0 t))
- (cond ((eq mode 'overwrite)
- (erase-buffer))
- ((eq mode 'append)
- (goto-char (point-max))))
- (point-marker))))))
+ (if redir
+ (if (nth 2 redir)
+ (funcall (nth 1 redir) mode)
+ (nth 1 redir))
+ (let* ((exists (get-file-buffer target))
+ (buf (find-file-noselect target t)))
+ (with-current-buffer buf
+ (if buffer-read-only
+ (error "Cannot write to read-only file `%s'" target))
+ (set (make-local-variable 'eshell-output-file-buffer)
+ (if (eq exists buf) 0 t))
+ (cond ((eq mode 'overwrite)
+ (erase-buffer))
+ ((eq mode 'append)
+ (goto-char (point-max))))
+ (point-marker))))))
+
((or (bufferp target)
(and (boundp 'eshell-buffer-shorthand)
(symbol-value 'eshell-buffer-shorthand)
@@ -363,15 +364,18 @@ it defaults to `insert'."
((eq mode 'append)
(goto-char (point-max))))
(point-marker))))
- ((functionp target)
- nil)
+
+ ((functionp target) nil)
+
((symbolp target)
(if (eq mode 'overwrite)
(set target nil))
target)
+
((or (eshell-processp target)
(markerp target))
target)
+
(t
(error "Illegal redirection target: %s"
(eshell-stringify target)))))
@@ -481,7 +485,8 @@ Returns what was actually sent, or nil if nothing was sent."
(let ((moving (= (point) target)))
(save-excursion
(goto-char target)
- (setq object (eshell-stringify object))
+ (unless (stringp object)
+ (setq object (eshell-stringify object)))
(insert-and-inherit object)
(set-marker target (point-marker)))
(if moving
@@ -489,7 +494,8 @@ Returns what was actually sent, or nil if nothing was sent."
((eshell-processp target)
(when (eq (process-status target) 'run)
- (setq object (eshell-stringify object))
+ (unless (stringp object)
+ (setq object (eshell-stringify object)))
(process-send-string target object)))
((consp target)
diff --git a/lisp/eshell/esh-module.el b/lisp/eshell/esh-module.el
index 4c8ffceef78..dcbf77364f4 100644
--- a/lisp/eshell/esh-module.el
+++ b/lisp/eshell/esh-module.el
@@ -1,6 +1,6 @@
;;; esh-module.el --- Eshell modules
-;; Copyright (C) 1999, 2000 Free Software Foundation
+;; Copyright (C) 1999, 2000, 2004 Free Software Foundation
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: processes
@@ -41,32 +41,33 @@ customizing the variable `eshell-modules-list'."
(defun eshell-load-defgroups (&optional directory)
"Load `defgroup' statements from Eshell's module files."
- (with-current-buffer
- (find-file-noselect (expand-file-name "esh-groups.el" directory))
- (erase-buffer)
- (insert ";;; do not modify this file; it is auto-generated -*- no-byte-compile: t -*-\n\n")
- (let ((files (directory-files (or directory
- (car command-line-args-left))
- nil "\\`em-.*\\.el\\'")))
- (while files
- (message "Loading defgroup from `%s'" (car files))
- (let (defgroup)
- (catch 'handled
- (with-current-buffer (find-file-noselect (car files))
- (goto-char (point-min))
- (while t
- (forward-sexp)
- (if (eobp) (throw 'handled t))
- (backward-sexp)
- (let ((begin (point))
- (defg (looking-at "(defgroup")))
+ (let ((vc-handled-backends nil)) ; avoid VC fucking things up
+ (with-current-buffer
+ (find-file-noselect (expand-file-name "esh-groups.el" directory))
+ (erase-buffer)
+ (insert ";;; do not modify this file; it is auto-generated -*- no-byte-compile: t -*-\n\n")
+ (let ((files (directory-files (or directory
+ (car command-line-args-left))
+ nil "\\`em-.*\\.el\\'")))
+ (while files
+ (message "Loading defgroup from `%s'" (car files))
+ (let (defgroup)
+ (catch 'handled
+ (with-current-buffer (find-file-noselect (car files))
+ (goto-char (point-min))
+ (while t
(forward-sexp)
- (if defg
- (setq defgroup (buffer-substring begin (point))))))))
- (if defgroup
- (insert defgroup "\n\n")))
- (setq files (cdr files))))
- (save-buffer)))
+ (if (eobp) (throw 'handled t))
+ (backward-sexp)
+ (let ((begin (point))
+ (defg (looking-at "(defgroup")))
+ (forward-sexp)
+ (if defg
+ (setq defgroup (buffer-substring begin (point))))))))
+ (if defgroup
+ (insert defgroup "\n\n")))
+ (setq files (cdr files))))
+ (save-buffer))))
;; 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-test.el b/lisp/eshell/esh-test.el
index 54edf5e35ab..076505da14e 100644
--- a/lisp/eshell/esh-test.el
+++ b/lisp/eshell/esh-test.el
@@ -167,13 +167,7 @@
(local-set-key [(control ?m)] 'eshell-test-goto-func)
(local-set-key [return] 'eshell-test-goto-func)
- (insert "Testing Eshell under "
- (format "GNU Emacs %s (%s%s)"
- emacs-version
- system-configuration
- (cond ((featurep 'motif) ", Motif")
- ((featurep 'x-toolkit) ", X toolkit")
- (t ""))))
+ (insert "Testing Eshell under " (emacs-version))
(switch-to-buffer test-buffer)
(delete-other-windows))
(eshell-for funcname (sort (all-completions "eshell-test--"
diff --git a/lisp/facemenu.el b/lisp/facemenu.el
index 3893e320655..e9af58fc73d 100644
--- a/lisp/facemenu.el
+++ b/lisp/facemenu.el
@@ -480,9 +480,19 @@ of colors that the current display can handle."
(when (and (null list) (> (display-color-cells) 0))
(setq list (defined-colors))
;; Delete duplicate colors.
+
+ ;; Identify duplicate colors by the name rather than the color
+ ;; value. For example, on MS-Windows, logical colors are added to
+ ;; the list that might have the same value but have different
+ ;; names and meanings. For example, `SystemMenuText' (the color
+ ;; w32 uses for the text in menu entries) and `SystemWindowText'
+ ;; (the default color w32 uses for the text in windows and
+ ;; dialogs) may be the same display color and be adjacent in the
+ ;; list. Detecting duplicates by name insures that both of these
+ ;; colors remain despite identical color values.
(let ((l list))
(while (cdr l)
- (if (facemenu-color-equal (car l) (car (cdr l)))
+ (if (facemenu-color-name-equal (car l) (car (cdr l)))
(setcdr l (cdr (cdr l)))
(setq l (cdr l)))))
(when (memq (display-visual-class) '(gray-scale pseudo-color direct-color))
@@ -515,6 +525,22 @@ determine the correct answer."
(cond ((equal a b) t)
((equal (color-values a) (color-values b)))))
+(defun facemenu-color-name-equal (a b)
+ "Return t if colors A and B are the same color.
+A and B should be strings naming colors. These names are
+downcased, stripped of spaces and the string `grey' is turned
+into `gray'. This accommodates alternative spellings of colors
+found commonly in the list. It returns nil if the colors differ."
+ (progn
+ (setq a (replace-regexp-in-string "grey" "gray"
+ (replace-regexp-in-string " " ""
+ (downcase a)))
+ b (replace-regexp-in-string "grey" "gray"
+ (replace-regexp-in-string " " ""
+ (downcase b))))
+
+ (equal a b)))
+
(defun facemenu-add-face (face &optional start end)
"Add FACE to text between START and END.
If START is nil or START to END is empty, add FACE to next typed character
diff --git a/lisp/faces.el b/lisp/faces.el
index 882ef1cba58..5ab91b5f1ba 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -240,27 +240,24 @@ If FRAME is omitted or nil, use the selected frame."
(defun face-differs-from-default-p (face &optional frame)
- "Non-nil if FACE displays differently from the default face.
+ "Return non-nil if FACE displays differently from the default face.
If the optional argument FRAME is given, report on face FACE in that frame.
If FRAME is t, report on the defaults for face FACE (for new frames).
-If FRAME is omitted or nil, use the selected frame.
-A face is considered to be ``the same'' as the default face if it is
-actually specified in the same way (equal attributes) or if it is
-fully-unspecified, and thus inherits the attributes of any face it
-is displayed on top of."
- (cond ((eq frame t) (setq frame nil))
- ((null frame) (setq frame (selected-frame))))
- (let* ((v1 (internal-lisp-face-p face frame))
- (n (if v1 (length v1) 0))
- (v2 (internal-lisp-face-p 'default frame))
- (i 1))
- (unless v1
- (error "Not a face: %S" face))
- (while (and (< i n)
- (or (eq 'unspecified (aref v1 i))
- (equal (aref v1 i) (aref v2 i))))
- (setq i (1+ i)))
- (< i n)))
+If FRAME is omitted or nil, use the selected frame."
+ (let ((attrs
+ '(:family :width :height :weight :slant :foreground
+ :foreground :background :underline :overline
+ :strike-through :box :inverse-video))
+ (differs nil))
+ (while (and attrs (not differs))
+ (let* ((attr (pop attrs))
+ (attr-val (face-attribute face attr frame t)))
+ (when (and
+ (not (eq attr-val 'unspecified))
+ (display-supports-face-attributes-p (list attr attr-val)
+ frame))
+ (setq differs attr))))
+ differs))
(defun face-nontrivial-p (face &optional frame)
@@ -1310,9 +1307,12 @@ If FRAME is nil, the current FRAME is used."
(memq 'tty options))
(and (memq 'motif options)
(featurep 'motif))
+ (and (memq 'gtk options)
+ (featurep 'gtk))
(and (memq 'lucid options)
(featurep 'x-toolkit)
- (not (featurep 'motif)))
+ (not (featurep 'motif))
+ (not (featurep 'gtk)))
(and (memq 'x-toolkit options)
(featurep 'x-toolkit))))
((eq req 'min-colors)
@@ -1487,33 +1487,6 @@ If omitted or nil, that stands for the selected frame's display."
(t
(> (tty-color-gray-shades display) 2)))))
-(defun display-supports-face-attributes-p (attributes &optional display)
- "Return non-nil if all the face attributes in ATTRIBUTES are supported.
-The optional argument DISPLAY can be a display name, a frame, or
-nil (meaning the selected frame's display)
-
-The definition of `supported' is somewhat heuristic, but basically means
-that a face containing all the attributes in ATTRIBUTES, when merged
-with the default face for display, can be represented in a way that's
-
- (1) different in appearance than the default face, and
- (2) `close in spirit' to what the attributes specify, if not exact.
-
-Point (2) implies that a `:weight black' attribute will be satisfied by
-any display that can display bold, and a `:foreground \"yellow\"' as long
-as it can display a yellowish color, but `:slant italic' will _not_ be
-satisfied by the tty display code's automatic substitution of a `dim'
-face for italic."
- (let ((frame
- (if (framep display)
- display
- (car (frames-on-display-list display)))))
- ;; For now, we assume that non-tty displays can support everything.
- ;; Later, we should add the ability to query about specific fonts,
- ;; colors, etc.
- (or (memq (framep frame) '(x w32 mac))
- (tty-supports-face-attributes-p attributes frame))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Background mode.
@@ -1777,7 +1750,7 @@ created."
;; Update a frame's faces when we change its default font.
-(defalias 'frame-update-faces 'ignore)
+(defalias 'frame-update-faces 'ignore "")
(make-obsolete 'frame-update-faces "no longer necessary." "21.1")
;; Update the colors of FACE, after FRAME's own colors have been
diff --git a/lisp/ffap.el b/lisp/ffap.el
index 38f7f92405e..dc78bd355be 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -941,7 +941,7 @@ If t, `ffap-tex-init' will initialize this when needed.")
;; * no commas (good for latex)
(file "--:$+<>@-Z_a-z~" "<@" "@>;.,!?:")
;; An url, or maybe a email/news message-id:
- (url "--:=&?$+@-Z_a-z~#,%" "^A-Za-z0-9" ":;.,!?")
+ (url "--:=&?$+@-Z_a-z~#,%;" "^A-Za-z0-9" ":;.,!?")
;; Find a string that does *not* contain a colon:
(nocolon "--9$+<>@-Z_a-z~" "<@" "@>;.,!?")
;; A machine:
diff --git a/lisp/files.el b/lisp/files.el
index ca6719055b0..1804432ee45 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -293,7 +293,7 @@ Normally auto-save files are written under other names."
:group 'auto-save)
(defcustom auto-save-file-name-transforms
- `(("\\`/[^/]*:\\(.+/\\)*\\(.*\\)"
+ `(("\\`/[^/]*:\\([^/]*/\\)*\\([^/]*\\)\\'"
;; Don't put "\\2" inside expand-file-name, since it will be
;; transformed to "/2" on DOS/Windows.
,(concat temporary-file-directory "\\2") t))
@@ -481,10 +481,15 @@ Runs the usual ange-ftp hook, but only for completion operations."
(defun convert-standard-filename (filename)
"Convert a standard file's name to something suitable for the current OS.
-This function's standard definition is trivial; it just returns the argument.
-However, on some systems, the function is redefined with a definition
-that really does change some file names to canonicalize certain
-patterns and to guarantee valid names."
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+This function's standard definition is trivial; it just returns
+the argument. However, on Windows and DOS, replace invalid
+characters. On DOS, make sure to obey the 8.3 limitations. On
+Windows, turn Cygwin names into native names, and also turn
+slashes into backslashes if the shell requires it (see
+`w32-shell-dos-semantics')."
filename)
(defun read-directory-name (prompt &optional dir default-dirname mustmatch initial)
@@ -521,8 +526,9 @@ the value of `default-directory'."
Not actually set up until the first time you use it.")
(defun parse-colon-path (cd-path)
- "Explode a colon-separated search path into a list of directory names.
-\(For values of `colon' equal to `path-separator'.)"
+ "Explode a search path into a list of directory names.
+Directories are separated by occurrences of `path-separator'
+\(which is colon in GNU and GNU-like systems)."
;; We could use split-string here.
(and cd-path
(let (cd-list (cd-start 0) cd-colon)
@@ -555,8 +561,10 @@ Not actually set up until the first time you use it.")
(defun cd (dir)
"Make DIR become the current buffer's default directory.
-If your environment includes a `CDPATH' variable, try each one of that
-colon-separated list of directories when resolving a relative directory name."
+If your environment includes a `CDPATH' variable, try each one of
+that list of directories (separated by occurrences of
+`path-separator') when resolving a relative directory name.
+The path separator is colon in GNU and GNU-like systems."
(interactive
(list (read-directory-name "Change default directory: "
default-directory default-directory
@@ -616,6 +624,8 @@ PATH-AND-SUFFIXES is a pair of lists (DIRECTORIES . SUFFIXES)."
(suffix (concat (regexp-opt (cdr path-and-suffixes) t) "\\'"))
(string-dir (file-name-directory string)))
(dolist (dir (car path-and-suffixes))
+ (unless dir
+ (setq dir default-directory))
(if string-dir (setq dir (expand-file-name string-dir dir)))
(when (file-directory-p dir)
(dolist (file (file-name-all-completions
@@ -640,9 +650,10 @@ This is an interface to the function `load'."
(defun file-remote-p (file)
"Test whether FILE specifies a location on a remote system."
- (let ((handler (find-file-name-handler file 'file-local-copy)))
+ (let ((handler (find-file-name-handler file 'file-remote-p)))
(if handler
- (get handler 'file-remote-p))))
+ (funcall handler 'file-remote-p file)
+ nil)))
(defun file-local-copy (file)
"Copy the file FILE into a temporary file on this machine.
@@ -661,21 +672,23 @@ The truename of a file name is found by chasing symbolic links
both at the level of the file and at the level of the directories
containing it, until no links are left at any level.
-The arguments COUNTER and PREV-DIRS are used only in recursive calls.
-Do not specify them in other calls."
- ;; COUNTER can be a cons cell whose car is the count of how many more links
- ;; to chase before getting an error.
+\(fn FILENAME)"
+ ;; COUNTER and PREV-DIRS are only used in recursive calls.
+ ;; COUNTER can be a cons cell whose car is the count of how many
+ ;; more links to chase before getting an error.
;; PREV-DIRS can be a cons cell whose car is an alist
;; of truenames we've just recently computed.
+ (cond ((or (string= filename "") (string= filename "~"))
+ (setq filename (expand-file-name filename))
+ (if (string= filename "")
+ (setq filename "/")))
+ ((and (string= (substring filename 0 1) "~")
+ (string-match "~[^/]*/?" filename))
+ (let ((first-part
+ (substring filename 0 (match-end 0)))
+ (rest (substring filename (match-end 0))))
+ (setq filename (concat (expand-file-name first-part) rest)))))
- ;; The last test looks dubious, maybe `+' is meant here? --simon.
- (if (or (string= filename "") (string= filename "~")
- (and (string= (substring filename 0 1) "~")
- (string-match "~[^/]*" filename)))
- (progn
- (setq filename (expand-file-name filename))
- (if (string= filename "")
- (setq filename "/"))))
(or counter (setq counter (list 100)))
(let (done
;; For speed, remove the ange-ftp completion handler from the list.
@@ -901,8 +914,11 @@ but the visited file name is available through the minibuffer history:
type M-n to pull it into the minibuffer.
Interactively, or if WILDCARDS is non-nil in a call from Lisp,
-expand wildcards (if any) and visit multiple files. Wildcard expansion
-can be suppressed by setting `find-file-wildcards'."
+expand wildcards (if any) and visit multiple files. You can
+suppress wildcard expansion by setting `find-file-wildcards'.
+
+To visit a file without any kind of conversion and without
+automatically choosing a major mode, use \\[find-file-literally]."
(interactive
(find-file-read-args "Find file: " nil))
(let ((value (find-file-noselect filename nil nil wildcards)))
@@ -1353,21 +1369,22 @@ that are visiting the various files."
rawfile truename number))))))
(defun find-file-noselect-1 (buf filename nowarn rawfile truename number)
- (let ((inhibit-read-only t)
- error)
+ (let (error)
(with-current-buffer buf
(kill-local-variable 'find-file-literally)
;; Needed in case we are re-visiting the file with a different
;; text representation.
(kill-local-variable 'buffer-file-coding-system)
(kill-local-variable 'cursor-type)
- (erase-buffer)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
(and (default-value 'enable-multibyte-characters)
(not rawfile)
(set-buffer-multibyte t))
(if rawfile
(condition-case ()
- (insert-file-contents-literally filename t)
+ (let ((inhibit-read-only t))
+ (insert-file-contents-literally filename t))
(file-error
(when (and (file-exists-p filename)
(not (file-readable-p filename)))
@@ -1377,7 +1394,8 @@ that are visiting the various files."
;; Unconditionally set error
(setq error t)))
(condition-case ()
- (insert-file-contents filename t)
+ (let ((inhibit-read-only t))
+ (insert-file-contents filename t))
(file-error
(when (and (file-exists-p filename)
(not (file-readable-p filename)))
@@ -2325,7 +2343,7 @@ However, the mode will not be changed if
(defun set-visited-file-name (filename &optional no-query along-with-file)
"Change name of file visited in current buffer to FILENAME.
The next time the buffer is saved it will go in the newly specified file.
-nil or empty string as argument means make buffer not be visiting any file.
+FILENAME nil or an empty string means make buffer not be visiting any file.
Remember to delete the initial contents of the minibuffer
if you wish to pass an empty string as the argument.
@@ -2897,10 +2915,8 @@ on a DOS/Windows machine, it returns FILENAME on expanded form."
(file-name-as-directory (expand-file-name (or directory
default-directory))))
(setq filename (expand-file-name filename))
- (let ((hf (find-file-name-handler filename 'file-local-copy))
- (hd (find-file-name-handler directory 'file-local-copy)))
- (when (and hf (not (get hf 'file-remote-p))) (setq hf nil))
- (when (and hd (not (get hd 'file-remote-p))) (setq hd nil))
+ (let ((hf (find-file-name-handler filename 'file-remote-p))
+ (hd (find-file-name-handler directory 'file-remote-p)))
(if ;; Conditions for separate trees
(or
;; Test for different drives on DOS/Windows
@@ -3010,7 +3026,7 @@ the last real save, but optional arg FORCE non-nil means delete anyway."
(defcustom before-save-hook nil
"Normal hook that is run before a buffer is saved to its file."
- :options '(copyright-update)
+ :options '(copyright-update time-stamp)
:type 'hook
:group 'files)
@@ -3466,7 +3482,10 @@ this function is called.
The idea behind the NOCONFIRM argument is that it should be
non-nil if the buffer is going to be reverted without asking the
user. In such situations, one has to be careful with potentially
-time consuming operations.")
+time consuming operations.
+
+For more information on how this variable is used by Auto Revert mode,
+see Info node `(emacs-xtra)Supporting additional buffers'.")
(defvar before-revert-hook nil
"Normal hook for `revert-buffer' to run before reverting.
@@ -4019,7 +4038,7 @@ by `sh' are supported."
"Expand wildcard pattern PATTERN.
This returns a list of file names which match the pattern.
-If PATTERN is written as an absolute relative file name,
+If PATTERN is written as an absolute file name,
the values are absolute also.
If PATTERN is written as a relative file name, it is interpreted
@@ -4230,7 +4249,7 @@ This works by running a directory listing program
whose name is in the variable `insert-directory-program'.
If WILDCARD, it also runs the shell specified by `shell-file-name'.
-When SWITCHES contains the long `--dired' option,this function
+When SWITCHES contains the long `--dired' option, this function
treats it specially, for the sake of dired. However, the
normally equivalent short `-D' option is just passed on to
`insert-directory-program', as any other option."
@@ -4307,6 +4326,8 @@ normally equivalent short `-D' option is just passed on to
;; If `insert-directory-program' failed, signal an error.
(unless (eq 0 result)
+ ;; Delete the error message it may have output.
+ (delete-region beg (point))
;; On non-Posix systems, we cannot open a directory, so
;; don't even try, because that will always result in
;; the ubiquitous "Access denied". Instead, show the
@@ -4329,21 +4350,26 @@ normally equivalent short `-D' option is just passed on to
(when (looking-at "//SUBDIRED//")
(delete-region (point) (progn (forward-line 1) (point)))
(forward-line -1))
- (let ((end (line-end-position)))
- (forward-word 1)
- (forward-char 3)
- (while (< (point) end)
- (let ((start (+ beg (read (current-buffer))))
- (end (+ beg (read (current-buffer)))))
- (if (= (char-after end) ?\n)
- (put-text-property start end 'dired-filename t)
- ;; It seems that we can't trust ls's output as to
- ;; byte positions of filenames.
- (put-text-property beg (point) 'dired-filename nil)
- (end-of-line))))
- (goto-char end)
- (beginning-of-line)
- (delete-region (point) (progn (forward-line 2) (point)))))
+ (if (looking-at "//DIRED//")
+ (let ((end (line-end-position)))
+ (forward-word 1)
+ (forward-char 3)
+ (while (< (point) end)
+ (let ((start (+ beg (read (current-buffer))))
+ (end (+ beg (read (current-buffer)))))
+ (if (= (char-after end) ?\n)
+ (put-text-property start end 'dired-filename t)
+ ;; It seems that we can't trust ls's output as to
+ ;; byte positions of filenames.
+ (put-text-property beg (point) 'dired-filename nil)
+ (end-of-line))))
+ (goto-char end)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 2) (point))))
+ (forward-line 1)
+ (if (looking-at "//DIRED-OPTIONS//")
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (forward-line 1))))
;; Now decode what read if necessary.
(let ((coding (or coding-system-for-read
@@ -4416,7 +4442,7 @@ be a predicate function such as `yes-or-no-p'."
:type '(choice (const :tag "Ask with yes-or-no-p" yes-or-no-p)
(const :tag "Ask with y-or-n-p" y-or-n-p)
(const :tag "Don't confirm" nil))
- :group 'emacs
+ :group 'convenience
:version "21.1")
(defun save-buffers-kill-emacs (&optional arg)
@@ -4470,7 +4496,7 @@ With prefix arg, silently save all file-visiting buffers, then kill."
;; Get a list of the indices of the args which are file names.
(file-arg-indices
(cdr (or (assq operation
- ;; The first five are special because they
+ ;; The first six are special because they
;; return a file name. We want to include the /:
;; in the return value.
;; So just avoid stripping it in the first place.
@@ -4479,11 +4505,21 @@ With prefix arg, silently save all file-visiting buffers, then kill."
(file-name-as-directory . nil)
(directory-file-name . nil)
(file-name-sans-versions . nil)
+ (find-backup-file-name . nil)
;; `identity' means just return the first arg
- ;; as stripped of its quoting.
- (substitute-in-file-name . identity)
+ ;; not stripped of its quoting.
+ (substitute-in-file-name identity)
+ ;; `add' means add "/:" to the result.
+ (file-truename add 0)
+ ;; `quote' means add "/:" to buffer-file-name.
+ (insert-file-contents quote 0)
+ ;; `unquote-then-quote' means set buffer-file-name
+ ;; temporarily to unquoted filename.
+ (verify-visited-file-modtime unquote-then-quote)
+ ;; List the arguments which are filenames.
(file-name-completion 1)
(file-name-all-completions 1)
+ (write-region 2 5)
(rename-file 0 1)
(copy-file 0 1)
(make-symbolic-link 0 1)
@@ -4491,9 +4527,12 @@ With prefix arg, silently save all file-visiting buffers, then kill."
;; For all other operations, treat the first argument only
;; as the file name.
'(nil 0))))
+ method
;; Copy ARGUMENTS so we can replace elements in it.
(arguments (copy-sequence arguments)))
- ;; Strip off the /: from the file names that have this handler.
+ (if (symbolp (car file-arg-indices))
+ (setq method (pop file-arg-indices)))
+ ;; Strip off the /: from the file names that have it.
(save-match-data
(while (consp file-arg-indices)
(let ((pair (nthcdr (car file-arg-indices) arguments)))
@@ -4504,9 +4543,21 @@ With prefix arg, silently save all file-visiting buffers, then kill."
"/"
(substring (car pair) 2)))))
(setq file-arg-indices (cdr file-arg-indices))))
- (if (eq file-arg-indices 'identity)
- (car arguments)
- (apply operation arguments))))
+ (cond ((eq method 'identity)
+ (car arguments))
+ ((eq method 'add)
+ (concat "/:" (apply operation arguments)))
+ ((eq method 'quote)
+ (prog1 (apply operation arguments)
+ (setq buffer-file-name (concat "/:" buffer-file-name))))
+ ((eq method 'unquote-then-quote)
+ (let (res)
+ (setq buffer-file-name (substring buffer-file-name 2))
+ (setq res (apply operation arguments))
+ (setq buffer-file-name (concat "/:" buffer-file-name))
+ res))
+ (t
+ (apply operation arguments)))))
(define-key ctl-x-map "\C-f" 'find-file)
(define-key ctl-x-map "\C-r" 'find-file-read-only)
diff --git a/lisp/find-dired.el b/lisp/find-dired.el
index 5bef4d6bf3a..2f499f243d7 100644
--- a/lisp/find-dired.el
+++ b/lisp/find-dired.el
@@ -55,6 +55,16 @@ LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output."
:group 'find-dired)
;;;###autoload
+(defcustom find-ls-subdir-switches "-al"
+ "`ls' switches for inserting subdirectories in `*Find*' buffers.
+This should contain the \"-l\" switch.
+Use the \"-F\" or \"-b\" switches if and only if you also use
+them for `find-ls-option'."
+ :type 'string
+ :group 'find-dired
+ :version "21.4")
+
+;;;###autoload
(defcustom find-grep-options
(if (or (eq system-type 'berkeley-unix)
(string-match "solaris2" system-configuration)
@@ -89,8 +99,7 @@ as the final argument."
(let ((dired-buffers dired-buffers))
;; Expand DIR ("" means default-directory), and make sure it has a
;; trailing slash.
- (setq dir (abbreviate-file-name
- (file-name-as-directory (expand-file-name dir))))
+ (setq dir (file-name-as-directory (expand-file-name dir)))
;; Check that it's really a directory.
(or (file-directory-p dir)
(error "find-dired needs a directory: %s" dir))
@@ -115,7 +124,7 @@ as the final argument."
(setq buffer-read-only nil)
(erase-buffer)
(setq default-directory dir
- find-args args ; save for next interactive call
+ find-args args ; save for next interactive call
args (concat find-dired-find-program " . "
(if (string= args "")
""
@@ -143,6 +152,7 @@ as the final argument."
;; this does no harm)
(set (make-local-variable 'dired-subdir-alist)
(list (cons default-directory (point-min-marker)))))
+ (set (make-local-variable 'dired-subdir-switches) find-ls-subdir-switches)
(setq buffer-read-only nil)
;; Subdir headlerline must come first because the first marker in
;; subdir-alist points there.
@@ -267,6 +277,7 @@ Thus ARG can also contain additional grep options."
(delete-process proc)
(force-mode-line-update)))
(message "find-dired %s finished." (current-buffer))))))
+
(provide 'find-dired)
diff --git a/lisp/follow.el b/lisp/follow.el
index 0ae6e175386..06857fc49e9 100644
--- a/lisp/follow.el
+++ b/lisp/follow.el
@@ -1561,7 +1561,7 @@ non-first windows in Follow Mode."
(or follow-internal-force-redisplay
(progn
(if (eq dest (point-max))
- ;; We're at the end, we have be be careful since
+ ;; We're at the end, we have to be careful since
;; the display can be aligned while `dest' can
;; be visible in several windows.
(cond
diff --git a/lisp/font-lock.el b/lisp/font-lock.el
index 27497057a91..1f6127f3ea5 100644
--- a/lisp/font-lock.el
+++ b/lisp/font-lock.el
@@ -1562,17 +1562,17 @@ Sets various variables using `font-lock-defaults' (or, if nil, using
(:foreground "DimGray" :weight bold :slant italic))
(((class grayscale) (background dark))
(:foreground "LightGray" :weight bold :slant italic))
- (((class color) (min-colors 88) (background light))
+ (((class color) (min-colors 88) (background light))
(:foreground "Firebrick"))
- (((class color) (min-colors 88) (background dark))
+ (((class color) (min-colors 88) (background dark))
(:foreground "chocolate1"))
- (((class color) (min-colors 16) (background light))
+ (((class color) (min-colors 16) (background light))
(:foreground "red"))
- (((class color) (min-colors 16) (background dark))
+ (((class color) (min-colors 16) (background dark))
(:foreground "red1"))
- (((class color) (min-colors 8) (background light))
+ (((class color) (min-colors 8) (background light))
(:foreground "red"))
- (((class color) (min-colors 8) (background dark))
+ (((class color) (min-colors 8) (background dark))
(:foreground "red1"))
(t (:weight bold :slant italic)))
"Font Lock mode face used to highlight comments."
@@ -1673,13 +1673,14 @@ Sets various variables using `font-lock-defaults' (or, if nil, using
'((((class color) (min-colors 88) (background light)) (:foreground "Red" :weight bold))
(((class color) (min-colors 88) (background dark)) (:foreground "Pink" :weight bold))
(((class color) (min-colors 16) (background light)) (:foreground "Red" :weight bold))
- (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :weight bold)) (((class color) (min-colors 8)) (:foreground "red"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :weight bold))
+ (((class color) (min-colors 8)) (:foreground "red"))
(t (:inverse-video t :weight bold)))
"Font Lock mode face used to highlight warnings."
:group 'font-lock-highlighting-faces)
(defface font-lock-preprocessor-face
- '((t :inherit 'font-lock-builtin-face))
+ '((t :inherit font-lock-builtin-face))
"Font Lock mode face used to highlight preprocessor directives."
:group 'font-lock-highlighting-faces)
@@ -1910,6 +1911,7 @@ This function could be MATCHER in a MATCH-ANCHORED `font-lock-keywords' item."
"proclaim" "declaim" "declare" "symbol-macrolet"
"lexical-let" "lexical-let*" "flet" "labels" "compiler-let"
"destructuring-bind" "macrolet" "tagbody" "block"
+ "multiple-value-bind"
"return" "return-from"
"with-accessors" "with-compilation-unit"
"with-condition-restarts" "with-hash-table-iterator"
diff --git a/lisp/format.el b/lisp/format.el
index 3f1f9c62987..9fb541a6943 100644
--- a/lisp/format.el
+++ b/lisp/format.el
@@ -741,13 +741,15 @@ to write these unknown annotations back into the file."
(message "Unknown annotations: %s" unknown-ans))))))
(defun format-subtract-regions (minu subtra)
- "Remove from the regions in MINUend the regions in SUBTRAhend.
+ "Remove from the regions in MINUEND the regions in SUBTRAHEND.
A region is a dotted pair (FROM . TO). Both parameters are lists of
regions. Each list must contain nonoverlapping, noncontiguous
regions, in descending order. The result is also nonoverlapping,
noncontiguous, and in descending order. The first element of MINUEND
can have a cdr of nil, indicating that the end of that region is not
-yet known."
+yet known.
+
+\(fn MINUEND SUBTRAHEND)"
(let* ((minuend (copy-alist minu))
(subtrahend (copy-alist subtra))
(m (car minuend))
@@ -800,8 +802,8 @@ in the region, it is treated as though it were DEFAULT."
Inserts each element of the given LIST of buffer annotations at its
appropriate place. Use second arg OFFSET if the annotations' locations are
not relative to the beginning of the buffer: annotations will be inserted
-at their location-OFFSET+1 \(ie, the offset is treated as the character number
-of the first character in the buffer)."
+at their location-OFFSET+1 \(ie, the offset is treated as the position of
+the first character in the buffer)."
(if (not offset)
(setq offset 0)
(setq offset (1- offset)))
@@ -911,7 +913,7 @@ The same TRANSLATIONS structure can be used in reverse for reading files."
(defun format-annotate-location (loc all ignore translations)
"Return annotation(s) needed at location LOC.
-This includes any properties that change between LOC-1 and LOC.
+This includes any properties that change between LOC - 1 and LOC.
If ALL is true, don't look at previous location, but generate annotations for
all non-nil properties.
Third argument IGNORE is a list of text-properties not to consider.
diff --git a/lisp/frame.el b/lisp/frame.el
index a470fbc0f97..446bda55775 100644
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -1,6 +1,6 @@
;;; frame.el --- multi-frame management independent of window systems
-;; Copyright (C) 1993, 1994, 1996, 1997, 2000, 2001, 2003
+;; Copyright (C) 1993, 1994, 1996, 1997, 2000, 2001, 2003, 2004
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -113,7 +113,7 @@ use (car ARGS) as a function to do the work.
Pass it BUFFER as first arg, and (cdr ARGS) gives the rest of the args."
(if (and args (symbolp (car args)))
(apply (car args) buffer (cdr args))
- (let ((window (get-buffer-window buffer t)))
+ (let ((window (get-buffer-window buffer 0)))
(or
;; If we have a window already, make it visible.
(when window
@@ -131,6 +131,7 @@ Pass it BUFFER as first arg, and (cdr ARGS) gives the rest of the args."
(let* ((pop-up-frames nil) (pop-up-windows t)
special-display-regexps special-display-buffer-names
(window (display-buffer buffer)))
+ ;; Only do it if this is a new window:
;; (set-window-dedicated-p window t)
window))
;; If no window yet, make one in a new frame.
@@ -552,7 +553,7 @@ is not considered (see `next-frame')."
(interactive)
(select-window (next-window (selected-window)
(> (minibuffer-depth) 0)
- t))
+ 0))
(select-frame-set-input-focus (selected-frame)))
(defun previous-multiframe-window ()
@@ -560,7 +561,7 @@ is not considered (see `next-frame')."
(interactive)
(select-window (previous-window (selected-window)
(> (minibuffer-depth) 0)
- t))
+ 0))
(select-frame-set-input-focus (selected-frame)))
(defun make-frame-on-display (display &optional parameters)
@@ -1190,9 +1191,8 @@ left untouched. FRAME nil or omitted means use the selected frame."
(make-variable-buffer-local 'show-trailing-whitespace)
(defcustom show-trailing-whitespace nil
- "*Non-nil means highlight trailing whitespace in face `trailing-whitespace'.
-
-Setting this variable makes it local to the current buffer."
+ "*Non-nil means highlight trailing whitespace.
+This is done in the face `trailing-whitespace'."
:tag "Highlight trailing whitespace."
:type 'boolean
:group 'font-lock)
@@ -1296,6 +1296,7 @@ if appropriate. It also arranges to cancel that timer when the next
command starts, by installing a pre-command hook."
(when (null blink-cursor-timer)
(add-hook 'pre-command-hook 'blink-cursor-end)
+ (internal-show-cursor nil nil)
(setq blink-cursor-timer
(run-with-timer blink-cursor-interval blink-cursor-interval
'blink-cursor-timer-function))))
diff --git a/lisp/generic.el b/lisp/generic.el
index d35a31a2b67..a951a0d53d8 100644
--- a/lisp/generic.el
+++ b/lisp/generic.el
@@ -1,6 +1,6 @@
;;; generic.el --- defining simple major modes with comment and font-lock
;;
-;; Copyright (C) 1997, 1999 Free Software Foundation, Inc.
+;; Copyright (C) 1997, 1999, 2004 Free Software Foundation, Inc.
;;
;; Author: Peter Breton <pbreton@cs.umb.edu>
;; Created: Fri Sep 27 1996
@@ -188,9 +188,6 @@ regexp in `generic-find-file-regexp'. If the value is nil,
&optional description)
"Create a new generic mode with NAME.
-Args: (NAME COMMENT-LIST KEYWORD-LIST FONT-LOCK-LIST AUTO-MODE-LIST
- FUNCTION-LIST &optional DESCRIPTION)
-
NAME should be a symbol; its string representation is used as the function
name. If DESCRIPTION is provided, it is used as the docstring for the new
function.
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog
index dc39720f79b..78c9f15f912 100644
--- a/lisp/gnus/ChangeLog
+++ b/lisp/gnus/ChangeLog
@@ -1,3 +1,23 @@
+2004-05-18 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * mm-view.el (mm-insert-inline): Make it work in read-only buffer.
+
+ * gnus-win.el (gnus-all-windows-visible-p): Don't consider
+ non-visible windows.
+
+2004-05-07 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * rfc2047.el (rfc2047-encode-message-header): Don't encode non-address
+ headers as address headers (which breaks if subject has a single ").
+
+2004-05-06 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * nnimap.el (nnimap-demule): Avoid string-as-multibyte.
+
+2004-04-21 Richard M. Stallman <rms@gnu.org>
+
+ * mailcap.el (mailcap-mime-data): Mark as risky.
+
2004-03-27 Juanma Barranquero <lektu@terra.es>
* gnus-srvr.el (gnus-server-prepare): Remove spurious call to `cdr'.
diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el
index fa082e7c1d0..4d0c18a8daf 100644
--- a/lisp/gnus/gnus-win.el
+++ b/lisp/gnus/gnus-win.el
@@ -1,5 +1,5 @@
;;; gnus-win.el --- window configuration functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002
+;; Copyright (C) 1996, 97, 98, 1999, 2000, 02, 2004
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
@@ -516,7 +516,7 @@ should have point."
(unless buffer
(error "Invalid buffer type: %s" type))
(if (and (setq buf (get-buffer (gnus-window-to-buffer-helper buffer)))
- (setq win (get-buffer-window buf t)))
+ (setq win (get-buffer-window buf 0)))
(if (memq 'point split)
(setq all-visible win))
(setq all-visible nil)))
diff --git a/lisp/gnus/mailcap.el b/lisp/gnus/mailcap.el
index 1663bd3f5f8..6d35e2196ae 100644
--- a/lisp/gnus/mailcap.el
+++ b/lisp/gnus/mailcap.el
@@ -271,6 +271,7 @@ validity. Otherwise, if it is a non-function Lisp symbol or list
whose car is a symbol, it is `eval'led to yield the validity. If it
is a string or list of strings, it represents a shell command to run
to return a true or false shell value for the validity.")
+(put 'mailcap-mime-data 'risky-local-variable t)
(defcustom mailcap-download-directory nil
"*Directory to which `mailcap-save-binary-file' downloads files by default.
diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el
index f7dfdb60f02..69cbd3d8a1d 100644
--- a/lisp/gnus/mm-view.el
+++ b/lisp/gnus/mm-view.el
@@ -1,5 +1,5 @@
;;; mm-view.el --- functions for viewing MIME objects
-;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 01, 2004 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
@@ -197,7 +197,8 @@
(defun mm-insert-inline (handle text)
"Insert TEXT inline from HANDLE."
- (let ((b (point)))
+ (let ((b (point))
+ (inhibit-read-only t))
(insert text)
(mm-handle-set-undisplayer
handle
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el
index 02cb87af28b..a7cf82317b5 100644
--- a/lisp/gnus/nnimap.el
+++ b/lisp/gnus/nnimap.el
@@ -1,5 +1,6 @@
;;; nnimap.el --- imap backend for Gnus
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+
+;; Copyright (C) 1998,1999,2000,01,02,2004 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Jim Radford <radford@robby.caltech.edu>
@@ -671,9 +672,12 @@ function is generally only called when Gnus is shutting down."
(nnoo-status-message 'nnimap server)))
(defun nnimap-demule (string)
- (funcall (if (and (fboundp 'string-as-multibyte)
- (subrp (symbol-function 'string-as-multibyte)))
- 'string-as-multibyte
+ ;; BEWARE: we used to use string-as-multibyte here which is braindead
+ ;; because it will turn accidental emacs-mule-valid byte sequences
+ ;; into multibyte chars. --Stef
+ (funcall (if (and (fboundp 'string-to-multibyte)
+ (subrp (symbol-function 'string-to-multibyte)))
+ 'string-to-multibyte
'identity)
(or string "")))
@@ -1383,5 +1387,5 @@ sure of changing the value of `foo'."
(provide 'nnimap)
-;;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b
+;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b
;;; nnimap.el ends here
diff --git a/lisp/gnus/rfc2047.el b/lisp/gnus/rfc2047.el
index 7c93160c455..f355ac8bbb4 100644
--- a/lisp/gnus/rfc2047.el
+++ b/lisp/gnus/rfc2047.el
@@ -1,5 +1,5 @@
;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages
-;; Copyright (C) 1998, 1999, 2000, 2002, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1998,1999,2000,02,03,2004 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -169,7 +169,7 @@ Should be called narrowed to the head of the message."
((eq method 'address-mime)
(rfc2047-encode-region (point) (point-max)))
((eq method 'mime)
- (let (rfc2047-encoding-type)
+ (let ((rfc2047-encoding-type method))
(rfc2047-encode-region (point) (point-max))))
((eq method 'default)
(if (and (featurep 'mule)
diff --git a/lisp/gnus/starttls.el b/lisp/gnus/starttls.el
index 0fd14cead55..c172e88c515 100644
--- a/lisp/gnus/starttls.el
+++ b/lisp/gnus/starttls.el
@@ -1,10 +1,11 @@
;;; starttls.el --- STARTTLS functions
-;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2003, 2004 Free Software Foundation, Inc.
;; Author: Daiki Ueno <ueno@unixuser.org>
+;; Author: Simon Josefsson <simon@josefsson.org>
;; Created: 1999/11/20
-;; Keywords: TLS, SSL, OpenSSL, mail, news
+;; Keywords: TLS, SSL, OpenSSL, GNUTLS, mail, news
;; This file is part of GNU Emacs.
@@ -30,6 +31,90 @@
;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP"
;; by Chris Newman <chris.newman@innosoft.com> (1999/06)
+;; This file now contain a combination of the two previous
+;; implementations both called "starttls.el". The first one is Daiki
+;; Ueno's starttls.el which uses his own "starttls" command line tool,
+;; and the second one is Simon Josefsson's starttls.el which uses
+;; "gnutls-cli" from GNUTLS.
+;;
+;; If "starttls" is available, it is prefered by the code over
+;; "gnutls-cli", for backwards compatibility. Use
+;; `starttls-use-gnutls' to toggle between implementations if you have
+;; both tools installed. It is recommended to use GNUTLS, though, as
+;; it performs more verification of the certificates.
+
+;; The GNUTLS support require GNUTLS 0.9.90 (released 2003-10-08) or
+;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls"
+;; from <ftp://ftp.opaopa.org/pub/elisp/>.
+
+;; Usage is similar to `open-network-stream'. For example:
+;;
+;; (when (setq tmp (starttls-open-stream
+;; "test" (current-buffer) "yxa.extundo.com" 25))
+;; (accept-process-output tmp 15)
+;; (process-send-string tmp "STARTTLS\n")
+;; (accept-process-output tmp 15)
+;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp))
+;; (process-send-string tmp "EHLO foo\n"))
+
+;; An example run yield the following output:
+;;
+;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65]
+;; 220 2.0.0 Ready to start TLS
+;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you
+;; 250-ENHANCEDSTATUSCODES
+;; 250-PIPELINING
+;; 250-EXPN
+;; 250-VERB
+;; 250-8BITMIME
+;; 250-SIZE
+;; 250-DSN
+;; 250-ETRN
+;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN
+;; 250-DELIVERBY
+;; 250 HELP
+;; nil
+;;
+;; With the message buffer containing:
+;;
+;; STARTTLS output:
+;; *** Starting TLS handshake
+;; - Server's trusted authorities:
+;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; - Certificate type: X.509
+;; - Got a certificate list of 2 certificates.
+;;
+;; - Certificate[0] info:
+;; # The hostname in the certificate matches 'yxa.extundo.com'.
+;; # valid since: Wed May 26 12:16:00 CEST 2004
+;; # expires at: Wed Jul 26 12:16:00 CEST 2023
+;; # serial number: 04
+;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a
+;; # version: #1
+;; # public key algorithm: RSA
+;; # Modulus: 1024 bits
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;;
+;; - Certificate[1] info:
+;; # valid since: Sun May 23 11:35:00 CEST 2004
+;; # expires at: Sun Jul 23 11:35:00 CEST 2023
+;; # serial number: 00
+;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae
+;; # version: #3
+;; # public key algorithm: RSA
+;; # Modulus: 1024 bits
+;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com
+;;
+;; - Peer's certificate issuer is unknown
+;; - Peer's certificate is NOT trusted
+;; - Version: TLS 1.0
+;; - Key Exchange: RSA
+;; - Cipher: ARCFOUR 128
+;; - MAC: SHA
+;; - Compression: NULL
+
;;; Code:
(defgroup starttls nil
@@ -37,18 +122,141 @@
:version "21.1"
:group 'mail)
+(defcustom starttls-gnutls-program "gnutls-cli"
+ "Name of GNUTLS command line tool.
+This program is used when GNUTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil."
+ :type 'string
+ :group 'starttls)
+
(defcustom starttls-program "starttls"
- "The program to run in a subprocess to open an TLSv1 connection."
+ "The program to run in a subprocess to open an TLSv1 connection.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
:type 'string
:group 'starttls)
+(defcustom starttls-use-gnutls (not (executable-find starttls-program))
+ "*Whether to use GNUTLS instead of the `starttls' command."
+ :type 'boolean
+ :group 'starttls)
+
(defcustom starttls-extra-args nil
- "Extra arguments to `starttls-program'."
+ "Extra arguments to `starttls-program'.
+This program is used when the `starttls' command is used,
+i.e. when `starttls-use-gnutls' is nil."
:type '(repeat string)
:group 'starttls)
+(defcustom starttls-extra-arguments nil
+ "Extra arguments to `starttls-program'.
+This program is used when GNUTLS is used, i.e. when
+`starttls-use-gnutls' is non-nil.
+
+For example, non-TLS compliant servers may require
+'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to
+find out which parameters are available."
+ :type '(repeat string)
+ :group 'starttls)
+
+(defcustom starttls-process-connection-type nil
+ "*Value for `process-connection-type' to use when starting STARTTLS process."
+ :type 'boolean
+ :group 'starttls)
+
+(defcustom starttls-connect "- Simple Client Mode:\n\n"
+ "*Regular expression indicating successful connection.
+The default is what GNUTLS's \"gnutls-cli\" outputs."
+ ;; GNUTLS cli.c:main() print this string when it is starting to run
+ ;; in the application read/write phase. If the logic, or the string
+ ;; itself, is modified, this must be updated.
+ :type 'regexp
+ :group 'starttls)
+
+(defcustom starttls-failure "\\*\\*\\* Handshake has failed"
+ "*Regular expression indicating failed TLS handshake.
+The default is what GNUTLS's \"gnutls-cli\" outputs."
+ ;; GNUTLS cli.c:do_handshake() print this string on failure. If the
+ ;; logic, or the string itself, is modified, this must be updated.
+ :type 'regexp
+ :group 'starttls)
+
+(defcustom starttls-success "- Compression: "
+ "*Regular expression indicating completed TLS handshakes.
+The default is what GNUTLS's \"gnutls-cli\" outputs."
+ ;; GNUTLS cli.c:do_handshake() calls, on success,
+ ;; common.c:print_info(), that unconditionally print this string
+ ;; last. If that logic, or the string itself, is modified, this
+ ;; must be updated.
+ :type 'regexp
+ :group 'starttls)
+
+(defun starttls-negotiate-gnutls (process)
+ "Negotiate TLS on process opened by `open-starttls-stream'.
+This should typically only be done once. It typically return a
+multi-line informational message with information about the
+handshake, or NIL on failure."
+ (let (buffer info old-max done-ok done-bad)
+ (if (null (setq buffer (process-buffer process)))
+ ;; XXX How to remove/extract the TLS negotiation junk?
+ (signal-process (process-id process) 'SIGALRM)
+ (with-current-buffer buffer
+ (save-excursion
+ (setq old-max (goto-char (point-max)))
+ (signal-process (process-id process) 'SIGALRM)
+ (while (and (processp process)
+ (eq (process-status process) 'run)
+ (save-excursion
+ (goto-char old-max)
+ (not (or (setq done-ok (re-search-forward
+ starttls-success nil t))
+ (setq done-bad (re-search-forward
+ starttls-failure nil t))))))
+ (accept-process-output process 1 100)
+ (sit-for 0.1))
+ (setq info (buffer-substring-no-properties old-max (point-max)))
+ (delete-region old-max (point-max))
+ (if (or (and done-ok (not done-bad))
+ ;; Prevent mitm that fake success msg after failure msg.
+ (and done-ok done-bad (< done-ok done-bad)))
+ info
+ (message "STARTTLS negotiation failed: %s" info)
+ nil))))))
+
(defun starttls-negotiate (process)
- (signal-process (process-id process) 'SIGALRM))
+ (if starttls-use-gnutls
+ (starttls-negotiate-gnutls process)
+ (signal-process (process-id process) 'SIGALRM)))
+
+(defun starttls-open-stream-gnutls (name buffer host service)
+ (message "Opening STARTTLS connection to `%s'..." host)
+ (let* (done
+ (old-max (with-current-buffer buffer (point-max)))
+ (process-connection-type starttls-process-connection-type)
+ (process (apply #'start-process name buffer
+ starttls-gnutls-program "-s" host
+ "-p" (if (integerp service)
+ (int-to-string service)
+ service)
+ starttls-extra-arguments)))
+ (process-kill-without-query process)
+ (while (and (processp process)
+ (eq (process-status process) 'run)
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char old-max)
+ (not (setq done (re-search-forward
+ starttls-connect nil t)))))
+ (accept-process-output process 0 100)
+ (sit-for 0.1))
+ (if done
+ (with-current-buffer buffer
+ (delete-region old-max done))
+ (delete-process process)
+ (setq process nil))
+ (message "Opening STARTTLS connection to `%s'...%s"
+ host (if done "done" "failed"))
+ process))
(defun starttls-open-stream (name buffer host service)
"Open a TLS connection for a service to a host.
@@ -64,13 +272,15 @@ BUFFER is the buffer (or `buffer-name') to associate with the process.
Third arg is name of the host to connect to, or its IP address.
Fourth arg SERVICE is name of the service desired, or an integer
specifying a port number to connect to."
- (let* ((process-connection-type nil)
- (process (apply #'start-process
- name buffer starttls-program
- host (format "%s" service)
- starttls-extra-args)))
- (process-kill-without-query process)
- process))
+ (if starttls-use-gnutls
+ (starttls-open-stream-gnutls name buffer host service)
+ (let* ((process-connection-type starttls-process-connection-type)
+ (process (apply #'start-process
+ name buffer starttls-program
+ host (format "%s" service)
+ starttls-extra-args)))
+ (process-kill-without-query process)
+ process)))
(provide 'starttls)
diff --git a/lisp/gs.el b/lisp/gs.el
index f160dca197a..2c38a55f6df 100644
--- a/lisp/gs.el
+++ b/lisp/gs.el
@@ -1,6 +1,6 @@
;;; gs.el --- interface to Ghostscript
-;; Copyright (C) 1998, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 2001, 2004 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: internal
@@ -39,12 +39,14 @@
(defvar gs-options
'("-q"
;"-dNOPAUSE"
+ "-dSAFER"
"-dBATCH"
"-sDEVICE=<device>"
"<file>")
"List of command line arguments to pass to Ghostscript.
Arguments may contain place-holders `<file>' for the name of the
input file, and `<device>' for the device to use.")
+(put 'gs-options 'risky-local-variable t)
(defun gs-options (device file)
"Return a list of command line options with place-holders replaced.
@@ -55,7 +57,6 @@ FILE is the value to substitute for the place-holder `<file>'."
option (replace-regexp-in-string "<file>" file option)))
gs-options))
-
;; The GHOSTVIEW property (taken from gv 3.5.8).
;;
;; Type:
@@ -196,7 +197,7 @@ the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful."
(setenv "GHOSTVIEW" window-and-pixmap-id)
(setq gs (apply 'start-process "gs" "*GS*" gs-program
(gs-options gs-device file)))
- (process-kill-without-query gs)
+ (set-process-query-on-exit-flag gs nil)
gs)
nil))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index ab76b5eb232..e534c6998a7 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -45,10 +45,10 @@ If there's no tutorial in that language, `TUTORIAL' is selected.
With ARG, you are asked to choose which language."
(interactive "P")
(let ((lang (if arg
- (let ((minibuffer-setup-hook minibuffer-setup-hook))
- (add-hook 'minibuffer-setup-hook
- 'minibuffer-completion-help)
- (read-language-name 'tutorial "Language: " "English"))
+ (let ((minibuffer-setup-hook minibuffer-setup-hook))
+ (add-hook 'minibuffer-setup-hook
+ 'minibuffer-completion-help)
+ (read-language-name 'tutorial "Language: " "English"))
(if (get-language-info current-language-environment 'tutorial)
current-language-environment
"English")))
@@ -63,6 +63,7 @@ With ARG, you are asked to choose which language."
(setq default-directory (expand-file-name "~/"))
(setq buffer-auto-save-file-name nil)
(insert-file-contents (expand-file-name filename data-directory))
+ (hack-local-variables)
(goto-char (point-min))
(search-forward "\n<<")
(beginning-of-line)
@@ -157,37 +158,37 @@ and the file name is displayed in the echo area."
;; Return the text we displayed.
(buffer-string))))))
-(defun help-split-fundoc (doc def)
- "Split a function docstring DOC into the actual doc and the usage info.
+(defun help-split-fundoc (docstring def)
+ "Split a function DOCSTRING into the actual doc and the usage info.
Return (USAGE . DOC) or nil if there's no usage info.
-DEF is the function whose usage we're looking for in DOC."
+DEF is the function whose usage we're looking for in DOCSTRING."
;; Functions can get the calling sequence at the end of the doc string.
;; In cases where `function' has been fset to a subr we can't search for
;; function's name in the doc string so we use `fn' as the anonymous
;; function name instead.
- (when (and doc (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" doc))
+ (when (and docstring (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring))
(cons (format "(%s%s"
;; Replace `fn' with the actual function name.
(if (consp def) "anonymous" def)
- (match-string 1 doc))
- (substring doc 0 (match-beginning 0)))))
-
-(defun help-add-fundoc-usage (doc arglist)
- "Add the usage info to the docstring DOC.
-If DOC already has a usage info, then just return DOC unchanged.
-The usage info is built from ARGLIST. DOC can be nil.
-ARGLIST can also be t or a string of the form \"(fun ARG1 ARG2 ...)\"."
- (unless (stringp doc) (setq doc "Not documented"))
- (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" doc) (eq arglist t))
- doc
- (format "%s%s%s" doc
- (if (string-match "\n?\n\\'" doc)
+ (match-string 1 docstring))
+ (substring docstring 0 (match-beginning 0)))))
+
+(defun help-add-fundoc-usage (docstring arglist)
+ "Add the usage info to DOCSTRING.
+If DOCSTRING already has a usage info, then just return it unchanged.
+The usage info is built from ARGLIST. DOCSTRING can be nil.
+ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
+ (unless (stringp docstring) (setq docstring "Not documented"))
+ (if (or (string-match "\n\n(fn\\(\\( .*\\)?)\\)\\'" docstring) (eq arglist t))
+ docstring
+ (concat docstring
+ (if (string-match "\n?\n\\'" docstring)
(if (< (- (match-end 0) (match-beginning 0)) 2) "\n" "")
"\n\n")
(if (and (stringp arglist)
(string-match "\\`([^ ]+\\(.*\\))\\'" arglist))
(concat "(fn" (match-string 1 arglist) ")")
- (help-make-usage 'fn arglist)))))
+ (format "%S" (help-make-usage 'fn arglist))))))
(defun help-function-arglist (def)
;; Handle symbols aliased to other symbols.
@@ -215,27 +216,13 @@ ARGLIST can also be t or a string of the form \"(fun ARG1 ARG2 ...)\"."
(intern (upcase name))))))
arglist)))
-(defvar help-C-source-directory
- (let ((dir (expand-file-name "src" source-directory)))
- (when (and (file-directory-p dir) (file-readable-p dir))
- dir))
- "Directory where the C source files of Emacs can be found.
-If nil, do not try to find the source code of functions and variables
-defined in C.")
-
-(defun help-subr-name (subr)
- (let ((name (prin1-to-string subr)))
- (if (string-match "\\`#<subr \\(.*\\)>\\'" name)
- (match-string 1 name)
- (error "Unexpected subroutine print name: %s" name))))
-
(defun help-C-file-name (subr-or-var kind)
"Return the name of the C file where SUBR-OR-VAR is defined.
KIND should be `var' for a variable or `subr' for a subroutine."
(let ((docbuf (get-buffer-create " *DOC*"))
(name (if (eq 'var kind)
(concat "V" (symbol-name subr-or-var))
- (concat "F" (help-subr-name subr-or-var)))))
+ (concat "F" (subr-name subr-or-var)))))
(with-current-buffer docbuf
(goto-char (point-min))
(if (eobp)
@@ -245,30 +232,72 @@ KIND should be `var' for a variable or `subr' for a subroutine."
(re-search-backward "S\\(.*\\)")
(let ((file (match-string 1)))
(if (string-match "\\.\\(o\\|obj\\)\\'" file)
- (replace-match ".c" t t file)
+ (setq file (replace-match ".c" t t file)))
+ (if (string-match "\\.c\\'" file)
+ (concat "src/" file)
file)))))
-(defun help-find-C-source (fun-or-var file kind)
- "Find the source location where SUBR-OR-VAR is defined in FILE.
-KIND should be `var' for a variable or `subr' for a subroutine."
- (setq file (expand-file-name file help-C-source-directory))
- (unless (file-readable-p file)
- (error "The C source file %s is not available"
- (file-name-nondirectory file)))
- (if (eq 'fun kind)
- (setq fun-or-var (indirect-function fun-or-var)))
- (with-current-buffer (find-file-noselect file)
- (goto-char (point-min))
- (unless (re-search-forward
- (if (eq 'fun kind)
- (concat "DEFUN[ \t\n]*([ \t\n]*\""
- (regexp-quote (help-subr-name fun-or-var))
- "\"")
- (concat "DEFVAR[A-Z_]*[ \t\n]*([ \t\n]*\""
- (regexp-quote (symbol-name fun-or-var))))
- nil t)
- (error "Can't find source for %s" fun))
- (cons (current-buffer) (match-beginning 0))))
+;;;###autoload
+(defface help-argument-name '((((supports :slant italic)) :inherit italic))
+ "Face to highlight argument names in *Help* buffers."
+ :group 'help)
+
+(defun help-default-arg-highlight (arg)
+ "Default function to highlight arguments in *Help* buffers.
+It returns ARG in face `help-argument-name'; ARG is also
+downcased if it displays differently than the default
+face (according to `face-differs-from-default-p')."
+ (propertize (if (face-differs-from-default-p 'help-argument-name)
+ (downcase arg)
+ arg)
+ 'face 'help-argument-name))
+
+(defun help-do-arg-highlight (doc args)
+ (with-syntax-table (make-syntax-table emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?\- "w")
+ (while args
+ (let ((arg (prog1 (car args) (setq args (cdr args)))))
+ (setq doc (replace-regexp-in-string
+ ;; This is heuristic, but covers all common cases
+ ;; except ARG1-ARG2
+ (concat "\\<" ; beginning of word
+ "\\(?:[a-z-]+-\\)?" ; for xxx-ARG
+ "\\("
+ arg
+ "\\)"
+ "\\(?:es\\|s\\|th\\)?" ; for ARGth, ARGs
+ "\\(?:-[a-z-]+\\)?" ; for ARG-xxx
+ "\\>") ; end of word
+ (help-default-arg-highlight arg)
+ doc t t 1))))
+ doc))
+
+(defun help-highlight-arguments (usage doc &rest args)
+ (when usage
+ (with-temp-buffer
+ (insert usage)
+ (goto-char (point-min))
+ (let ((case-fold-search nil)
+ (next (not (or args (looking-at "\\["))))
+ (opt nil))
+ ;; Make a list of all arguments
+ (skip-chars-forward "^ ")
+ (while next
+ (or opt (not (looking-at " &")) (setq opt t))
+ (if (not (re-search-forward " \\([\\[(]*\\)\\([^] &)\.]+\\)" nil t))
+ (setq next nil)
+ (setq args (cons (match-string 2) args))
+ (when (and opt (string= (match-string 1) "("))
+ ;; A pesky CL-style optional argument with default value,
+ ;; so let's skip over it
+ (search-backward "(")
+ (goto-char (scan-sexps (point) 1)))))
+ ;; Highlight aguments in the USAGE string
+ (setq usage (help-do-arg-highlight (buffer-string) args))
+ ;; Highlight arguments in the DOC string
+ (setq doc (and doc (help-do-arg-highlight doc args))))))
+ ;; Return value is like the one from help-split-fundoc, but highlighted
+ (cons usage doc))
;;;###autoload
(defun describe-function-1 (function)
@@ -335,14 +364,16 @@ KIND should be `var' for a variable or `subr' for a subroutine."
(when (re-search-backward
"^;;; Generated autoloads from \\(.*\\)" nil t)
(setq file-name (match-string 1)))))))
- (when (and (null file-name) (subrp def) help-C-source-directory)
+ (when (and (null file-name) (subrp def))
;; Find the C source file name.
- (setq file-name (concat "src/" (help-C-file-name def 'subr))))
+ (setq file-name (if (get-buffer " *DOC*")
+ (help-C-file-name def 'subr)
+ 'C-source)))
(when file-name
(princ " in `")
;; We used to add .el to the file name,
;; but that's completely wrong when the user used load-file.
- (princ file-name)
+ (princ (if (eq file-name 'C-source) "C source code" file-name))
(princ "'")
;; Make a hyperlink to the library.
(with-current-buffer standard-output
@@ -354,55 +385,74 @@ KIND should be `var' for a variable or `subr' for a subroutine."
(when (commandp function)
(let* ((remapped (command-remapping function))
(keys (where-is-internal
- (or remapped function) overriding-local-map nil nil)))
+ (or remapped function) overriding-local-map nil nil))
+ non-modified-keys)
+ ;; Which non-control non-meta keys run this command?
+ (dolist (key keys)
+ (if (member (event-modifiers (aref key 0)) '(nil (shift)))
+ (push key non-modified-keys)))
(when remapped
(princ "It is remapped to `")
(princ (symbol-name remapped))
(princ "'"))
+
(when keys
(princ (if remapped " which is bound to " "It is bound to "))
;; FIXME: This list can be very long (f.ex. for self-insert-command).
- (princ (mapconcat 'key-description keys ", ")))
- (when (or remapped keys)
+ ;; If there are many, remove them from KEYS.
+ (if (< (length non-modified-keys) 10)
+ (princ (mapconcat 'key-description keys ", "))
+ (dolist (key non-modified-keys)
+ (setq keys (delq key keys)))
+ (if keys
+ (progn
+ (princ (mapconcat 'key-description keys ", "))
+ (princ ", and many ordinary text characters"))
+ (princ "many ordinary text characters"))))
+ (when (or remapped keys non-modified-keys)
(princ ".")
(terpri))))
(let* ((arglist (help-function-arglist def))
(doc (documentation function))
(usage (help-split-fundoc doc function)))
- ;; If definition is a keymap, skip arglist note.
- (unless (keymapp def)
- (princ (cond
- (usage (setq doc (cdr usage)) (car usage))
- ((listp arglist) (help-make-usage function arglist))
- ((stringp arglist) arglist)
- ;; Maybe the arglist is in the docstring of the alias.
- ((let ((fun function))
- (while (and (symbolp fun)
- (setq fun (symbol-function fun))
- (not (setq usage (help-split-fundoc
- (documentation fun)
- function)))))
- usage)
- (car usage))
- ((or (stringp def)
- (vectorp def))
- (format "\nMacro: %s" (format-kbd-macro def)))
- (t "[Missing arglist. Please make a bug report.]")))
- (terpri))
- (let ((obsolete (and
- ;; function might be a lambda construct.
- (symbolp function)
- (get function 'byte-obsolete-info))))
- (when obsolete
- (terpri)
- (princ "This function is obsolete")
- (if (nth 2 obsolete) (princ (format " since %s" (nth 2 obsolete))))
- (princ ";") (terpri)
- (princ (if (stringp (car obsolete)) (car obsolete)
- (format "use `%s' instead." (car obsolete))))
- (terpri)))
- (terpri)
- (princ (or doc "Not documented.")))))
+ (with-current-buffer standard-output
+ ;; If definition is a keymap, skip arglist note.
+ (unless (keymapp def)
+ (let* ((use (cond
+ (usage (setq doc (cdr usage)) (car usage))
+ ((listp arglist)
+ (format "%S" (help-make-usage function arglist)))
+ ((stringp arglist) arglist)
+ ;; Maybe the arglist is in the docstring of the alias.
+ ((let ((fun function))
+ (while (and (symbolp fun)
+ (setq fun (symbol-function fun))
+ (not (setq usage (help-split-fundoc
+ (documentation fun)
+ function)))))
+ usage)
+ (car usage))
+ ((or (stringp def)
+ (vectorp def))
+ (format "\nMacro: %s" (format-kbd-macro def)))
+ (t "[Missing arglist. Please make a bug report.]")))
+ (high (help-highlight-arguments use doc)))
+ (insert (car high) "\n")
+ (setq doc (cdr high))))
+ (let ((obsolete (and
+ ;; function might be a lambda construct.
+ (symbolp function)
+ (get function 'byte-obsolete-info))))
+ (when obsolete
+ (princ "\nThis function is obsolete")
+ (when (nth 2 obsolete)
+ (insert (format " since %s" (nth 2 obsolete))))
+ (insert ";\n"
+ (if (stringp (car obsolete)) (car obsolete)
+ (format "use `%s' instead." (car obsolete)))
+ "\n"))
+ (insert "\n"
+ (or doc "Not documented.")))))))
;; Variables
@@ -560,13 +610,13 @@ it is displayed along with the global value."
(when (and (null file-name)
(integerp (get variable 'variable-documentation)))
;; It's a variable not defined in Elisp but in C.
- (if help-C-source-directory
- (setq file-name
- (concat "src/" (help-C-file-name variable 'var)))
- (princ "\n\nDefined in core C code.")))
+ (setq file-name
+ (if (get-buffer " *DOC*")
+ (help-C-file-name variable 'var)
+ 'C-source)))
(when file-name
(princ "\n\nDefined in `")
- (princ file-name)
+ (princ (if (eq file-name 'C-source) "C source code" file-name))
(princ "'.")
(with-current-buffer standard-output
(save-excursion
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 149eebb3d36..11656ec368c 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -147,14 +147,13 @@ The format is (FUNCTION ARGS...).")
:supertype 'help-xref
'help-function (lambda (fun file)
(require 'find-func)
+ (when (eq file 'C-source)
+ (setq file
+ (help-C-file-name (indirect-function fun) 'fun)))
;; Don't use find-function-noselect because it follows
;; aliases (which fails for built-in functions).
(let ((location
- (cond
- ((bufferp file) (cons file fun))
- ((string-match "\\`src/\\(.*\\.c\\)" file)
- (help-find-C-source fun (match-string 1 file) 'fun))
- (t (find-function-search-for-symbol fun nil file)))))
+ (find-function-search-for-symbol fun nil file)))
(pop-to-buffer (car location))
(goto-char (cdr location))))
'help-echo (purecopy "mouse-2, RET: find function's definition"))
@@ -162,11 +161,9 @@ The format is (FUNCTION ARGS...).")
(define-button-type 'help-variable-def
:supertype 'help-xref
'help-function (lambda (var &optional file)
- (let ((location
- (cond
- ((string-match "\\`src/\\(.*\\.c\\)" file)
- (help-find-C-source var (match-string 1 file) 'var))
- (t (find-variable-noselect var file)))))
+ (when (eq file 'C-source)
+ (setq file (help-C-file-name var 'var)))
+ (let ((location (find-variable-noselect var file)))
(pop-to-buffer (car location))
(goto-char (cdr location))))
'help-echo (purecopy"mouse-2, RET: find variable's definition"))
@@ -195,14 +192,17 @@ Commands:
;;;###autoload
(defun help-mode-finish ()
+ (let ((entry (assq (selected-window) view-return-to-alist)))
+ (if entry (setcdr entry (cons (selected-window)
+ help-return-method))
+ (setq view-return-to-alist
+ (cons (cons (selected-window) help-return-method)
+ view-return-to-alist))))
(when (eq major-mode 'help-mode)
;; View mode's read-only status of existing *Help* buffer is lost
;; by with-output-to-temp-buffer.
(toggle-read-only 1)
- (help-make-xrefs (current-buffer)))
- (setq view-return-to-alist
- (list (cons (selected-window) help-return-method))))
-
+ (help-make-xrefs (current-buffer))))
;; Grokking cross-reference information in doc strings and
;; hyperlinking it.
@@ -577,12 +577,11 @@ help buffer."
(goto-char position)))))
(defun help-go-back ()
- "Invoke the [back] button (if any) in the Help mode buffer."
+ "Go back to previous topic in this help buffer."
(interactive)
- (let ((back-button (button-at (1- (point-max)))))
- (if back-button
- (button-activate back-button)
- (error "No [back] button"))))
+ (if help-xref-stack
+ (help-xref-go-back (current-buffer))
+ (error "No previous help buffer.")))
(defun help-do-xref (pos function args)
"Call the help cross-reference function FUNCTION with args ARGS.
diff --git a/lisp/help.el b/lisp/help.el
index b589de94474..fc43d8db03d 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1,6 +1,6 @@
;;; help.el --- help commands for Emacs
-;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1985, 1986, 1993, 1994, 1998, 1999, 2000, 2001, 2002, 2004
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -313,19 +313,61 @@ of the key sequence that ran this command."
(defun view-emacs-news (&optional arg)
"Display info on recent changes to Emacs.
-With numeric argument, display information on correspondingly older changes."
+With argument, display info only for the selected version."
(interactive "P")
- (let* ((arg (if arg (prefix-numeric-value arg) 0))
- (file (cond ((eq arg 0) "NEWS")
- ((eq arg 1) "ONEWS")
- (t
- (nth (- arg 2)
- (nreverse (directory-files data-directory
- nil "^ONEWS\\.[0-9]+$"
- nil)))))))
- (if file
- (view-file (expand-file-name file data-directory))
- (error "No such old news"))))
+ (if (not arg)
+ (view-file (expand-file-name "NEWS" data-directory))
+ (let* ((map (sort
+ (delete-dups
+ (apply
+ 'nconc
+ (mapcar
+ (lambda (file)
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name file data-directory))
+ (let (res)
+ (while (re-search-forward
+ (if (string-match "^ONEWS\\.[0-9]+$" file)
+ "Changes in \\(?:Emacs\\|version\\)?[ \t]*\\([0-9]+\\(?:\\.[0-9]+\\)?\\)"
+ "^\* [^0-9\n]*\\([0-9]+\\.[0-9]+\\)") nil t)
+ (setq res (cons (list (match-string-no-properties 1)
+ file) res)))
+ res)))
+ (append '("NEWS" "ONEWS")
+ (directory-files data-directory nil
+ "^ONEWS\\.[0-9]+$" nil)))))
+ (lambda (a b)
+ (string< (car b) (car a)))))
+ (current (caar map))
+ (version (completing-read
+ (format "Read NEWS for the version (default %s): " current)
+ (mapcar 'car map) nil nil nil nil current))
+ (file (cadr (assoc version map)))
+ res)
+ (if (not file)
+ (error "No news is good news")
+ (view-file (expand-file-name file data-directory))
+ (widen)
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat (if (string-match "^ONEWS\\.[0-9]+$" file)
+ "Changes in \\(?:Emacs\\|version\\)?[ \t]*"
+ "^\* [^0-9\n]*") version)
+ nil t)
+ (beginning-of-line)
+ (narrow-to-region
+ (point)
+ (save-excursion
+ (while (and (setq res
+ (re-search-forward
+ (if (string-match "^ONEWS\\.[0-9]+$" file)
+ "Changes in \\(?:Emacs\\|version\\)?[ \t]*\\([0-9]+\\(?:\\.[0-9]+\\)?\\)"
+ "^\* [^0-9\n]*\\([0-9]+\\.[0-9]+\\)") nil t))
+ (equal (match-string-no-properties 1) version)))
+ (or res (goto-char (point-max)))
+ (beginning-of-line)
+ (point))))))))
(defun view-todo (&optional arg)
"Display the Emacs TODO list."
diff --git a/lisp/hexl.el b/lisp/hexl.el
index cc36c37602e..883700933a8 100644
--- a/lisp/hexl.el
+++ b/lisp/hexl.el
@@ -217,7 +217,9 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode.
(set-buffer-modified-p modified))
(make-local-variable 'hexl-max-address)
(setq hexl-max-address max-address)
- (hexl-goto-address original-point))
+ (condition-case nil
+ (hexl-goto-address original-point)
+ (error nil)))
;; We do not turn off the old major mode; instead we just
;; override most of it. That way, we can restore it perfectly.
@@ -405,7 +407,7 @@ This function is indented to be used as eldoc callback."
Signal error if ADDRESS out of range."
(interactive "nAddress: ")
(if (or (< address 0) (> address hexl-max-address))
- (error "Out of hexl region"))
+ (error "Out of hexl region"))
(goto-char (hexl-address-to-marker address)))
(defun hexl-goto-hex-address (hex-address)
diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el
index 9492d5565f6..96678d2bc9a 100644
--- a/lisp/ibuf-ext.el
+++ b/lisp/ibuf-ext.el
@@ -1,6 +1,6 @@
;;; ibuf-ext.el --- extensions for ibuffer
-;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
;; Author: Colin Walters <walters@verbum.org>
;; Maintainer: John Paul Wallington <jpw@gnu.org>
@@ -1224,19 +1224,62 @@ to move by. The default is `ibuffer-marked-char'."
;;;###autoload
(defun ibuffer-jump-to-buffer (name)
- "Move point to the buffer whose name is NAME."
+ "Move point to the buffer whose name is NAME.
+
+If called interactively, prompt for a buffer name and go to the
+corresponding line in the Ibuffer buffer. If said buffer is in a
+hidden group filter, open it.
+
+If `ibuffer-jump-offer-only-visible-buffers' is non-nil, only offer
+visible buffers in the completion list. Calling the command with
+a prefix argument reverses the meaning of that variable."
(interactive (list nil))
- (let ((table (mapcar #'(lambda (x)
- (cons (buffer-name (car x))
- (caddr x)))
- (ibuffer-current-state-list t))))
- (when (null table)
- (error "No buffers!"))
- (when (interactive-p)
- (setq name (completing-read "Jump to buffer: " table nil t)))
- (ibuffer-aif (assoc name table)
- (goto-char (cdr it))
- (error "No buffer with name %s" name))))
+ (let ((only-visible ibuffer-jump-offer-only-visible-buffers))
+ (when current-prefix-arg
+ (setq only-visible (not only-visible)))
+ (if only-visible
+ (let ((table (mapcar #'(lambda (x)
+ (buffer-name (car x)))
+ (ibuffer-current-state-list))))
+ (when (null table)
+ (error "No buffers!"))
+ (when (interactive-p)
+ (setq name (completing-read "Jump to buffer: "
+ table nil t))))
+ (when (interactive-p)
+ (setq name (read-buffer "Jump to buffer: " nil t))))
+ (when (not (string= "" name))
+ (let (buf-point)
+ ;; Blindly search for our buffer: it is very likely that it is
+ ;; not in a hidden filter group.
+ (ibuffer-map-lines #'(lambda (buf marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
+ t nil)
+ (when (and
+ (null buf-point)
+ (not (null ibuffer-hidden-filter-groups)))
+ ;; We did not find our buffer. It must be in a hidden filter
+ ;; group, so go through all hidden filter groups to find it.
+ (catch 'found
+ (dolist (group ibuffer-hidden-filter-groups)
+ (ibuffer-jump-to-filter-group group)
+ (ibuffer-toggle-filter-group)
+ (ibuffer-map-lines #'(lambda (buf marks)
+ (when (string= (buffer-name buf) name)
+ (setq buf-point (point))
+ nil))
+ t group)
+ (if buf-point
+ (throw 'found nil)
+ (ibuffer-toggle-filter-group)))))
+ (if (null buf-point)
+ ;; Still not found even though we expanded all hidden filter
+ ;; groups: that must be because it's hidden by predicate:
+ ;; we won't bother trying to display it.
+ (error "No buffer with name %s" name)
+ (goto-char buf-point))))))
;;;###autoload
(defun ibuffer-diff-with-file ()
diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el
index d6b4c2e1da8..effcafd9240 100644
--- a/lisp/ibuf-macs.el
+++ b/lisp/ibuf-macs.el
@@ -93,7 +93,9 @@ Note that this macro expands into a `defun' for a function named
ibuffer-make-column-NAME. If INLINE is non-nil, then the form will be
inlined into the compiled format versions. This means that if you
change its definition, you should explicitly call
-`ibuffer-recompile-formats'."
+`ibuffer-recompile-formats'.
+
+\(fn SYMBOL (&key NAME INLINE PROPS SUMMARIZER) &rest BODY)"
(let* ((sym (intern (concat "ibuffer-make-column-"
(symbol-name symbol))))
(bod-1 `(with-current-buffer buffer
@@ -135,7 +137,9 @@ DESCRIPTION is a short string describing the sorting method.
For sorting, the forms in BODY will be evaluated with `a' bound to one
buffer object, and `b' bound to another. BODY should return a non-nil
-value if and only if `a' is \"less than\" `b'."
+value if and only if `a' is \"less than\" `b'.
+
+\(fn NAME DOCUMENTATION (&key DESCRIPTION) &rest BODY)"
`(progn
(defun ,(intern (concat "ibuffer-do-sort-by-" (symbol-name name))) ()
,(or documentation "No :documentation specified for this sorting method.")
@@ -189,7 +193,9 @@ ACTIVE-OPSTRING is a string which will be displayed to the user in a
confirmation message, in the form:
\"Really ACTIVE-OPSTRING x buffers?\"
COMPLEX means this function is special; see the source code of this
-macro for exactly what it does."
+macro for exactly what it does.
+
+\(fn OP ARGS DOCUMENTATION (&key INTERACTIVE MARK MODIFIER-P DANGEROUS OPSTRING ACTIVE-OPSTRING COMPLEX) &rest BODY)"
`(progn
(defun ,(intern (concat (if (string-match "^ibuffer-do" (symbol-name op))
"" "ibuffer-do-") (symbol-name op)))
@@ -265,7 +271,9 @@ DESCRIPTION is a short string describing the filter.
BODY should contain forms which will be evaluated to test whether or
not a particular buffer should be displayed or not. The forms in BODY
will be evaluated with BUF bound to the buffer object, and QUALIFIER
-bound to the current value of the filter."
+bound to the current value of the filter.
+
+\(fn NAME DOCUMENTATION (&key READER DESCRIPTION) &rest BODY)"
(let ((fn-name (intern (concat "ibuffer-filter-by-" (symbol-name name)))))
`(progn
(defun ,fn-name (qualifier)
diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el
index a1fd3195d46..fef9b7f811d 100644
--- a/lisp/ibuffer.el
+++ b/lisp/ibuffer.el
@@ -268,6 +268,12 @@ This variable takes precedence over filtering, and even
(const :tag "Always except minibuffer" :value :nomini))
:group 'ibuffer)
+(defcustom ibuffer-jump-offer-only-visible-buffers nil
+ "If non-nil, only offer buffers visible in the Ibuffer buffer
+in completion lists of the `ibuffer-jump-to-buffer' command."
+ :type 'boolean
+ :group 'ibuffer)
+
(defcustom ibuffer-use-header-line (boundp 'header-line-format)
"If non-nil, display a header line containing current filters."
:type 'boolean
@@ -357,6 +363,7 @@ directory, like `default-directory'."
(define-key map (kbd "u") 'ibuffer-unmark-forward)
(define-key map (kbd "=") 'ibuffer-diff-with-file)
(define-key map (kbd "j") 'ibuffer-jump-to-buffer)
+ (define-key map (kbd "M-g") 'ibuffer-jump-to-buffer)
(define-key map (kbd "DEL") 'ibuffer-unmark-backward)
(define-key map (kbd "M-DEL") 'ibuffer-unmark-all)
(define-key map (kbd "* *") 'ibuffer-unmark-all)
@@ -2166,6 +2173,7 @@ If optional arg SILENT is non-nil, do not display progress messages."
(member name ibuffer-hidden-filter-groups)))
(bmarklist (cdr group)))
(unless (and (null bmarklist)
+ (not disabled)
ext-loaded
(null ibuffer-show-empty-filter-groups))
(ibuffer-insert-filter-group
diff --git a/lisp/ido.el b/lisp/ido.el
index 6a66ce0388d..4cbc88cf037 100644
--- a/lisp/ido.el
+++ b/lisp/ido.el
@@ -1,6 +1,6 @@
;;; ido.el --- interactively do things with buffers and files.
-;; Copyright (C) 1996-2003 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2004 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Based on: iswitchb by Stephen Eglen <stephen@cns.ed.ac.uk>
@@ -30,8 +30,9 @@
;; for ido-switch-buffer and found the inspiration for ido-find-file.
;; The ido package would never have existed without his work.
-;; Also thanks to Klaus Berndl, Rohit Namjoshi, Robert Fenk, Alex Schroeder,
-;; Bill Benedetto, and Stephen Eglen for bug fixes and improvements.
+;; Also thanks to Klaus Berndl, Rohit Namjoshi, Robert Fenk, Alex
+;; Schroeder, Bill Benedetto, Stephen Eglen, and many others for bug
+;; fixes and improvements.
;;; History
@@ -55,7 +56,7 @@
;; so I invented a common "ido-" namespace for the merged packages.
;;
;; This version is based on ido.el version 1.57 released on
-;; gnu.emacs.sources adapted for emacs 21.4 to use command remapping
+;; gnu.emacs.sources adapted for emacs 21.5 to use command remapping
;; and optionally hooking the read-buffer and read-file-name functions.
;;
;; Prefix matching was added by Klaus Berndl <klaus.berndl@sdm.de> based on
@@ -1667,8 +1668,7 @@ If INITIAL is non-nil, it specifies the initial input string."
((memq ido-exit '(edit chdir))
(cond
((memq ido-cur-item '(file dir))
- (let* ((process-environment (cons "HOME=/" process-environment)) ;; cheat read-file-name
- (read-file-name-function nil)
+ (let* ((read-file-name-function nil)
(edit (eq ido-exit 'edit))
(d ido-current-directory)
(f ido-text-init)
@@ -1676,7 +1676,9 @@ If INITIAL is non-nil, it specifies the initial input string."
(setq ido-text-init "")
(while new
(setq new (if edit
- (read-file-name (concat prompt "[EDIT] ") d (concat d f) nil f)
+ (read-file-name (concat prompt "[EDIT] ")
+ (expand-file-name d)
+ (concat d f) nil f)
f)
d (or (file-name-directory new) "/")
f (file-name-nondirectory new)
@@ -3807,15 +3809,19 @@ For details of keybindings, do `\\[describe-function] ido-find-file'."
;;; Helper functions for other programs
+(put 'dired-do-rename 'ido 'ignore)
+
;;;###autoload
(defun ido-read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
"Read file name, prompting with PROMPT and completing in directory DIR.
See `read-file-name' for additional parameters."
(cond
((or (eq predicate 'file-directory-p)
+ (eq (get this-command 'ido) 'dir)
(memq this-command ido-read-file-name-as-directory-commands))
(ido-read-directory-name prompt dir default-filename mustmatch initial))
- ((and (not (memq this-command ido-read-file-name-non-ido))
+ ((and (not (eq (get this-command 'ido) 'ignore))
+ (not (memq this-command ido-read-file-name-non-ido))
(or (null predicate) (eq predicate 'file-exists-p)))
(let* (filename
ido-saved-vc-hb
diff --git a/lisp/ielm.el b/lisp/ielm.el
index aa60d5de6c3..944e2453cb9 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -1,6 +1,6 @@
;;; ielm.el --- interaction mode for Emacs Lisp
-;; Copyright (C) 1994, 2002, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2002, 2003, 2004 Free Software Foundation, Inc.
;; Author: David Smith <maa036@lancaster.ac.uk>
;; Maintainer: FSF
@@ -49,12 +49,57 @@
:type 'boolean
:group 'ielm)
+(defcustom ielm-prompt-read-only t
+ "If non-nil, the IELM prompt is read only.
+The read only region includes the newline before the prompt.
+Setting this variable does not affect existing IELM runs.
+This works by setting the buffer-local value of `comint-prompt-read-only'.
+Setting that value directly affects new prompts in the current buffer.
+
+If this option is enabled, then the safe way to temporarily
+override the read-only-ness of ielm prompts is to call
+`comint-kill-whole-line' or `comint-kill-region' with no
+narrowing in effect. This way you will be certain that none of
+the remaining prompts will be accidentally messed up. You may
+wish to put something like the following in your `.emacs' file:
+
+\(add-hook 'ielm-mode-hook
+ '(lambda ()
+ (define-key ielm-map \"\C-w\" 'comint-kill-region)
+ (define-key ielm-map [C-S-backspace]
+ 'comint-kill-whole-line)))
+
+If you set `comint-prompt-read-only' to t, you might wish to use
+`comint-mode-hook' and `comint-mode-map' instead of
+`ielm-mode-hook' and `ielm-map'. That will affect all comint
+buffers, including ielm buffers. If you sometimes use ielm on
+text-only terminals or with `emacs -nw', you might wish to use
+another binding for `comint-kill-whole-line'."
+ :type 'boolean
+ :group 'ielm
+ :version "21.4")
+
(defcustom ielm-prompt "ELISP> "
- "Prompt used in IELM."
+ "Prompt used in IELM.
+Setting this variable does not affect existing IELM runs.
+
+Interrupting the IELM process with \\<ielm-map>\\[comint-interrupt-subjob],
+and then restarting it using \\[ielm], makes the then current
+default value affect _new_ prompts. Unless the new prompt
+differs only in text properties from the old one, IELM will no
+longer recognize the old prompts. However, executing \\[ielm]
+does not update the prompt of an *ielm* buffer with a running process.
+For IELM buffers that are not called `*ielm*', you can execute
+\\[inferior-emacs-lisp-mode] in that IELM buffer to update the value,
+for new prompts. This works even if the buffer has a running process."
:type 'string
- :group 'ielm
- :get #'(lambda (symbol) (substring-no-properties (symbol-value symbol)))
- :set #'(lambda (symbol value) (set symbol (propertize value 'read-only t 'rear-nonsticky t))))
+ :group 'ielm)
+
+(defvar ielm-prompt-internal "ELISP> "
+ "Stored value of `ielm-prompt' in the current IELM buffer.
+This is an internal variable used by IELM. Its purpose is to
+prevent a running IELM process from being messed up when the user
+customizes `ielm-prompt'.")
(defcustom ielm-dynamic-return t
"*Controls whether \\<ielm-map>\\[ielm-return] has intelligent behaviour in IELM.
@@ -145,9 +190,7 @@ This variable is buffer-local.")
(define-key ielm-map "\C-c\C-v" 'ielm-print-working-buffer))
(defvar ielm-font-lock-keywords
- (list
- (cons (concat "^" (regexp-quote ielm-prompt)) 'font-lock-keyword-face)
- '("\\(^\\*\\*\\*[^*]+\\*\\*\\*\\)\\(.*$\\)"
+ '(("\\(^\\*\\*\\*[^*]+\\*\\*\\*\\)\\(.*$\\)"
(1 font-lock-comment-face)
(2 font-lock-constant-face)))
"Additional expressions to highlight in ielm buffers.")
@@ -250,8 +293,7 @@ simply inserts a newline."
(defun ielm-send-input nil
"Evaluate the Emacs Lisp expression after the prompt."
(interactive)
- (let ((buf (current-buffer))
- ielm-input) ; set by ielm-input-sender
+ (let (ielm-input) ; set by ielm-input-sender
(comint-send-input) ; update history, markers etc.
(ielm-eval-input ielm-input)))
@@ -374,7 +416,7 @@ simply inserts a newline."
(setq ** *)
(setq * ielm-result))
(setq ielm-output (concat ielm-output "\n"))))
- (setq ielm-output (concat ielm-output ielm-prompt))
+ (setq ielm-output (concat ielm-output ielm-prompt-internal))
(comint-output-filter (ielm-process) ielm-output)))
;;; Process and marker utilities
@@ -414,8 +456,8 @@ The current working buffer may be changed (with a call to
`set-buffer', or with \\[ielm-change-working-buffer]), and its value
is preserved between successive evaluations. In this way, expressions
may be evaluated in a different buffer than the *ielm* buffer.
-Display the name of the working buffer with \\[ielm-print-working-buffer],
-or the buffer itself with \\[ielm-display-working-buffer].
+By default, its name is shown on the mode line; you can always display
+it with \\[ielm-print-working-buffer], or the buffer itself with \\[ielm-display-working-buffer].
During evaluations, the values of the variables `*', `**', and `***'
are the results of the previous, second previous and third previous
@@ -426,14 +468,16 @@ buffer, then the values in the working buffer are used. The variables
Expressions evaluated by IELM are not subject to `debug-on-quit' or
`debug-on-error'.
-The behaviour of IELM may be customised with the following variables:
-* To stop beeping on error, set `ielm-noisy' to nil
+The behaviour of IELM may be customized with the following variables:
+* To stop beeping on error, set `ielm-noisy' to nil.
* If you don't like the prompt, you can change it by setting `ielm-prompt'.
-* Set `ielm-dynamic-return' to nil for bindings like `lisp-interaction-mode'
+* If you do not like that the prompt is (by default) read-only, set
+ `ielm-prompt-read-only' to nil.
+* Set `ielm-dynamic-return' to nil for bindings like `lisp-interaction-mode'.
* Entry to this mode runs `comint-mode-hook' and `ielm-mode-hook'
(in that order).
-Customised bindings may be defined in `ielm-map', which currently contains:
+Customized bindings may be defined in `ielm-map', which currently contains:
\\{ielm-map}"
(interactive)
(comint-mode)
@@ -443,15 +487,16 @@ Customised bindings may be defined in `ielm-map', which currently contains:
(setq comint-input-sender 'ielm-input-sender)
(setq comint-process-echoes nil)
(make-local-variable 'comint-dynamic-complete-functions)
+ (set (make-local-variable 'ielm-prompt-internal) ielm-prompt)
+ (set (make-local-variable 'comint-prompt-read-only) ielm-prompt-read-only)
(setq comint-dynamic-complete-functions
'(ielm-tab comint-replace-by-expanded-history ielm-complete-filename ielm-complete-symbol))
(setq comint-get-old-input 'ielm-get-old-input)
(make-local-variable 'comint-completion-addsuffix)
- (setq comint-completion-addsuffix
- (cons (char-to-string directory-sep-char) ""))
-
+ (setq comint-completion-addsuffix '("/" . ""))
(setq major-mode 'inferior-emacs-lisp-mode)
(setq mode-name "IELM")
+ (setq mode-line-process '(":%s on " (:eval (buffer-name ielm-working-buffer))))
(use-local-map ielm-map)
(set-syntax-table emacs-lisp-mode-syntax-table)
@@ -494,10 +539,11 @@ Customised bindings may be defined in `ielm-map', which currently contains:
(insert ielm-header)
(ielm-set-pm (point-max))
(unless comint-use-prompt-regexp-instead-of-fields
- (add-text-properties
- (point-min) (point-max)
- '(rear-nonsticky t field output inhibit-line-move-field-capture t)))
- (comint-output-filter (ielm-process) ielm-prompt)
+ (let ((inhibit-read-only t))
+ (add-text-properties
+ (point-min) (point-max)
+ '(rear-nonsticky t field output inhibit-line-move-field-capture t))))
+ (comint-output-filter (ielm-process) ielm-prompt-internal)
(set-marker comint-last-input-start (ielm-pm))
(set-process-filter (get-buffer-process (current-buffer)) 'comint-output-filter))
@@ -521,12 +567,13 @@ Customised bindings may be defined in `ielm-map', which currently contains:
"Interactively evaluate Emacs Lisp expressions.
Switches to the buffer `*ielm*', or creates it if it does not exist."
(interactive)
- (if (comint-check-proc "*ielm*")
- nil
- (save-excursion
- (set-buffer (get-buffer-create "*ielm*"))
- (inferior-emacs-lisp-mode)))
- (pop-to-buffer "*ielm*"))
+ (let (old-point)
+ (unless (comint-check-proc "*ielm*")
+ (with-current-buffer (get-buffer-create "*ielm*")
+ (unless (zerop (buffer-size)) (setq old-point (point)))
+ (inferior-emacs-lisp-mode)))
+ (pop-to-buffer "*ielm*")
+ (when old-point (push-mark old-point))))
(provide 'ielm)
diff --git a/lisp/iimage.el b/lisp/iimage.el
new file mode 100644
index 00000000000..d138498ca3a
--- /dev/null
+++ b/lisp/iimage.el
@@ -0,0 +1,134 @@
+;;; iimage.el --- Inline image minor mode.
+
+;; Copyright (C) 2004 Free Software Foundation
+
+;; Author: KOSEKI Yoshinori <kose@meadowy.org>
+;; Maintainer: KOSEKI Yoshinori <kose@meadowy.org>
+;; Keywords: multimedia
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Iimage is a minor mode that display a images, when image-filename
+;; exists in buffer.
+;; http://www.netlaputa.ne.jp/~kose/Emacs/iimage.html
+;;
+;; Add to your `~/.emacs':
+;; (autoload 'iimage-mode "iimage" "SUpport Inline image minor mode." t)
+;;
+;; ** Display images in *Info* buffer.
+;;
+;; (add-hook 'info-mode-hook 'turn-on-iimage-mode)
+;;
+;; .texinfo: @file{file://foo.png}
+;; .info: `file://foo.png'
+;;
+;; ** Display images in Wiki buffer.
+;;
+;; (add-hook 'wiki-mode-hook 'turn-on-iimage-mode)
+;;
+;; wiki-file: [[foo.png]]
+
+;;; Code:
+
+(eval-when-compile
+ (require 'image-file))
+
+(defconst iimage-version "1.0")
+(defvar iimage-mode nil)
+(defvar iimage-mode-map nil)
+
+;; Set up key map.
+(unless iimage-mode-map
+ (setq iimage-mode-map (make-sparse-keymap))
+ (define-key iimage-mode-map "\C-l" 'iimage-recenter))
+
+(defun iimage-recenter (&optional arg)
+"Re-draw images and recenter."
+ (interactive "P")
+ (iimage-mode-buffer 0)
+ (iimage-mode-buffer 1)
+ (recenter arg))
+
+(defvar iimage-mode-image-filename-regex
+ (concat "[-+./_0-9a-zA-Z]+\\."
+ (regexp-opt (nconc (mapcar #'upcase
+ image-file-name-extensions)
+ image-file-name-extensions)
+ t)))
+
+(defvar iimage-mode-image-regex-alist
+ `((,(concat "\\(`?file://\\|\\[\\[\\|<\\|`\\)?"
+ "\\(" iimage-mode-image-filename-regex "\\)"
+ "\\(\\]\\]\\|>\\|'\\)?") . 2))
+"*Alist of filename REGEXP vs NUM.
+Each element looks like (REGEXP . NUM).
+NUM specifies which parenthesized expression in the regexp.
+
+image filename regex exsamples:
+ file://foo.png
+ `file://foo.png'
+ \\[\\[foo.gif]]
+ <foo.png>
+ foo.JPG
+")
+
+(defun turn-on-iimage-mode ()
+"Unconditionally turn on iimage mode."
+ (interactive)
+ (iimage-mode 1))
+
+(defun turn-off-iimage-mode ()
+"Unconditionally turn off iimage mode."
+ (interactive)
+ (iimage-mode 0))
+
+(defun iimage-mode-buffer (arg)
+"Display/Undisplay Images.
+With numeric ARG, display the images if and only if ARG is positive."
+ (interactive)
+ (let ((ing (if (numberp arg)
+ (> arg 0)
+ iimage-mode))
+ (modp (buffer-modified-p (current-buffer)))
+ file buffer-read-only)
+ (save-excursion
+ (goto-char (point-min))
+ (dolist (pair iimage-mode-image-regex-alist)
+ (while (re-search-forward (car pair) nil t)
+ (if (and (setq file (match-string (cdr pair)))
+ (setq file (expand-file-name file default-directory))
+ (file-exists-p file))
+ (if ing
+ (add-text-properties (match-beginning 0) (match-end 0)
+ (list 'display (create-image file)))
+ (remove-text-properties (match-beginning 0) (match-end 0)
+ '(display)))))))
+ (set-buffer-modified-p modp)))
+
+(define-minor-mode iimage-mode
+ "Toggle inline image minor mode."
+ nil " iImg" iimage-mode-map
+ (run-hooks 'iimage-mode-hook)
+ (iimage-mode-buffer iimage-mode))
+
+(provide 'iimage)
+
+;;; arch-tag: f6f8e29a-08f6-4a12-9496-51e67441ce65
+;;; iimage.el ends here
diff --git a/lisp/image.el b/lisp/image.el
index 0e71bd4a349..88e38186d7b 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1,6 +1,6 @@
;;; image.el --- image API
-;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 99, 2000, 01, 04 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: multimedia
@@ -48,6 +48,17 @@ IMAGE-TYPE must be a pair (PREDICATE . TYPE). PREDICATE is called
with one argument, a string containing the image data. If PREDICATE returns
a non-nil value, TYPE is the image's type.")
+;;;###autoload
+(defvar image-library-alist nil
+ "Alist of image types vs external libraries needed to display them.
+
+Each element is a list (IMAGE-TYPE LIBRARY...), where the car is a symbol
+representing a supported image type, and the rest are strings giving
+alternate filenames for the corresponding external libraries to load.
+They are tried in the order they appear on the list; if none of them can
+be loaded, the running session of Emacs won't display the image type.
+No entries are needed for pbm and xbm images; they're always supported.")
+;;;###autoload (put 'image-library-alist 'risky-local-variable t)
(defun image-jpeg-p (data)
"Value is non-nil if DATA, a string, consists of JFIF image data.
@@ -111,8 +122,8 @@ be determined."
(defun image-type-available-p (type)
"Value is non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
- (and (boundp 'image-types) (not (null (memq type image-types)))))
-
+ (and (fboundp 'init-image-library)
+ (init-image-library type image-library-alist)))
;;;###autoload
(defun create-image (file-or-data &optional type data-p &rest props)
@@ -176,7 +187,7 @@ means display it in the right marginal area."
;;;###autoload
-(defun insert-image (image &optional string area)
+(defun insert-image (image &optional string area slice)
"Insert IMAGE into current buffer at point.
IMAGE is displayed by inserting STRING into the current buffer
with a `display' property whose value is the image. STRING is
@@ -184,7 +195,12 @@ defaulted if you omit it.
AREA is where to display the image. AREA nil or omitted means
display it in the text area, a value of `left-margin' means
display it in the left marginal area, a value of `right-margin'
-means display it in the right marginal area."
+means display it in the right marginal area.
+SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
+means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
+specifying the X and Y positions and WIDTH and HEIGHT of image area
+to insert. A float value 0.0 - 1.0 means relative to the width or
+height of the image; integer values are taken as pixel values."
;; Use a space as least likely to cause trouble when it's a hidden
;; character in the buffer.
(unless string (setq string " "))
@@ -204,7 +220,40 @@ means display it in the right marginal area."
(let ((start (point)))
(insert string)
(add-text-properties start (point)
- `(display ,image rear-nonsticky (display)))))
+ `(display ,(if slice
+ (list (cons 'slice slice) image)
+ image) rear-nonsticky (display)))))
+
+
+(defun insert-sliced-image (image &optional string area rows cols)
+ (unless string (setq string " "))
+ (unless (eq (car-safe image) 'image)
+ (error "Not an image: %s" image))
+ (unless (or (null area) (memq area '(left-margin right-margin)))
+ (error "Invalid area %s" area))
+ (if area
+ (setq image (list (list 'margin area) image))
+ ;; Cons up a new spec equal but not eq to `image' so that
+ ;; inserting it twice in a row (adjacently) displays two copies of
+ ;; the image. Don't try to avoid this by looking at the display
+ ;; properties on either side so that we DTRT more often with
+ ;; cut-and-paste. (Yanking killed image text next to another copy
+ ;; of it loses anyway.)
+ (setq image (cons 'image (cdr image))))
+ (let ((x 0.0) (dx (/ 1.0001 (or cols 1)))
+ (y 0.0) (dy (/ 1.0001 (or rows 1))))
+ (while (< y 1.0)
+ (while (< x 1.0)
+ (let ((start (point)))
+ (insert string)
+ (add-text-properties start (point)
+ `(display ,(list (list 'slice x y dx dy) image)
+ rear-nonsticky (display)))
+ (setq x (+ x dx))))
+ (setq x 0.0
+ y (+ y dy))
+ (insert (propertize "\n" 'line-height 0)))))
+
;;;###autoload
diff --git a/lisp/imenu.el b/lisp/imenu.el
index 42f50fba3a4..e0b57440fd8 100644
--- a/lisp/imenu.el
+++ b/lisp/imenu.el
@@ -890,6 +890,7 @@ Returns t for rescan and otherwise a position number."
(setq name (completing-read prompt
prepared-index-alist
nil t nil 'imenu--history-list name)))
+
(cond ((not (stringp name)) nil)
((string= name (car imenu--rescan-item)) t)
(t
@@ -1015,7 +1016,10 @@ This value becomes local in every buffer when it is set.")
(if (equal item imenu--rescan-item)
(progn
(imenu--cleanup)
+ ;; Make sure imenu-update-menubar redoes everything.
+ (setq imenu-menubar-modified-tick -1)
(setq imenu--index-alist nil)
+ (setq imenu--last-menubar-index-alist nil)
(imenu-update-menubar)
t)
(imenu item)
diff --git a/lisp/info-look.el b/lisp/info-look.el
index 35138121838..644ee3d6c20 100644
--- a/lisp/info-look.el
+++ b/lisp/info-look.el
@@ -1,7 +1,7 @@
;;; info-look.el --- major-mode-sensitive Info index lookup facility
;; An older version of this was known as libc.el.
-;; Copyright (C) 1995,96,97,98,99,2001,2003,2004 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96,97,98,99,2001,03,04 Free Software Foundation, Inc.
;; Author: Ralph Schleicher <rs@nunatak.allgaeu.org>
;; (did not show signs of life (Nov 2001) -stef)
@@ -408,12 +408,11 @@ If optional argument QUERY is non-nil, query for the help mode."
(message "No %s help available for `%s'" topic mode)
;; Recursively setup cross references.
;; But refer only to non-void modes.
- (mapcar (lambda (arg)
- (or (info-lookup->initialized topic arg)
- (info-lookup-setup-mode topic arg))
- (and (eq (info-lookup->initialized topic arg) t)
- (setq refer-modes (cons arg refer-modes))))
- (info-lookup->other-modes topic mode))
+ (dolist (arg (info-lookup->other-modes topic mode))
+ (or (info-lookup->initialized topic arg)
+ (info-lookup-setup-mode topic arg))
+ (and (eq (info-lookup->initialized topic arg) t)
+ (setq refer-modes (cons arg refer-modes))))
(setq refer-modes (nreverse refer-modes))
;; Build the full completion alist.
(setq completions
@@ -887,6 +886,22 @@ Return nil if there is nothing appropriate in the buffer near point."
"awk")
((string-equal item "gawk, versions of, information about, printing")
"gawk"))))))
+
+;; This misses some things which occur as node names but not in the
+;; index. Unfortunately it also picks up the wrong one of multiple
+;; entries for the same term in some cases. --fx
+(info-lookup-maybe-add-help
+ :mode 'cfengine-mode
+ :regexp "[[:alnum:]_]+\\(:?()\\)?"
+ :doc-spec '(("(cfengine-Reference)Variable Index"
+ (lambda (item)
+ ;; Index entries may be like `IsPlain()'
+ (if (string-match "\\([[:alnum:]_]+\\)()" item)
+ (match-string 1 item)
+ item))
+ ;; This gets functions in evaluated classes. Other
+ ;; possible patterns don't seem to work too well.
+ "`" "(")))
(provide 'info-look)
diff --git a/lisp/info.el b/lisp/info.el
index c67a1a5f0c7..43e1dafcc6f 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -66,29 +66,29 @@ The Lisp code is executed when the node is selected.")
(put 'Info-enable-active-nodes 'risky-local-variable t)
(defface info-node
- '((((class color) (background light)) (:foreground "brown" :weight bold :slant italic))
- (((class color) (background dark)) (:foreground "white" :weight bold :slant italic))
- (t (:weight bold :slant italic)))
+ '((((class color) (background light)) :foreground "brown" :weight bold :slant italic)
+ (((class color) (background dark)) :foreground "white" :weight bold :slant italic)
+ (t :weight bold :slant italic))
"Face for Info node names."
:group 'info)
(defface info-menu-5
- '((((class color)) (:foreground "red1"))
- (t (:underline t)))
+ '((((class color)) :foreground "red1")
+ (t :underline t))
"Face for every third `*' in an Info menu."
:group 'info)
(defface info-xref
- '((((class color) (background light)) (:foreground "blue"))
- (((class color) (background dark)) (:foreground "cyan"))
- (t (:underline t)))
+ '((((class color) (background light)) :foreground "blue")
+ (((class color) (background dark)) :foreground "cyan")
+ (t :underline t))
"Face for Info cross-references."
:group 'info)
(defface info-xref-visited
- '((((class color) (background light)) (:foreground "magenta4"))
- (((class color) (background dark)) (:foreground "magenta4"))
- (t (:underline t)))
+ '((t :inherit info-xref)
+ (((class color) (background light)) :foreground "magenta4")
+ (((class color) (background dark)) :foreground "magenta3")) ;"violet"?
"Face for visited Info cross-references."
:group 'info)
@@ -110,12 +110,12 @@ A header-line does not scroll with the rest of the buffer."
:group 'info)
(defface info-header-xref
- '((t (:inherit info-xref)))
+ '((t :inherit info-xref))
"Face for Info cross-references in a node header."
:group 'info)
(defface info-header-node
- '((t (:inherit info-node)))
+ '((t :inherit info-node))
"Face for Info nodes in a node header."
:group 'info)
@@ -239,10 +239,11 @@ Marker points nowhere if file has no tag table.")
(defvar Info-index-alternatives nil
"List of possible matches for last `Info-index' command.")
-(defvar Info-reference-name nil
- "Name of the selected cross-reference.
-Point is moved to the proper occurrence of this name within a node
-after selecting it.")
+(defvar Info-point-loc nil
+ "Point location within a selected node.
+If string, the point is moved to the proper occurrence of the
+name of the followed cross reference within a selected node.
+If number, the point is moved to the corresponding line.")
(defvar Info-standalone nil
"Non-nil if Emacs was started solely as an Info browser.")
@@ -449,28 +450,39 @@ Do the right thing if the file has been compressed or zipped."
"Like `info' but show the Info buffer in another window."
(interactive (if current-prefix-arg
(list (read-file-name "Info file name: " nil nil t))))
- (let (same-window-buffer-names)
+ (let (same-window-buffer-names same-window-regexps)
(info file)))
-;;;###autoload (add-hook 'same-window-buffer-names "*info*")
+;;;###autoload (add-hook 'same-window-regexps "\\*info\\*\\(\\|<[0-9]+>\\)")
;;;###autoload
-(defun info (&optional file)
+(defun info (&optional file buffer)
"Enter Info, the documentation browser.
Optional argument FILE specifies the file to examine;
the default is the top-level directory of Info.
Called from a program, FILE may specify an Info node of the form
`(FILENAME)NODENAME'.
+Optional argument BUFFER specifies the Info buffer name;
+the default buffer name is *info*. If BUFFER exists,
+just switch to BUFFER. Otherwise, create a new buffer
+with the top-level Info directory.
-In interactive use, a prefix argument directs this command
-to read a file name from the minibuffer.
+In interactive use, a non-numeric prefix argument directs
+this command to read a file name from the minibuffer.
+A numeric prefix argument selects an Info buffer with the prefix number
+appended to the Info buffer name.
The search path for Info files is in the variable `Info-directory-list'.
The top-level Info directory is made by combining all the files named `dir'
in all the directories in that path."
- (interactive (if current-prefix-arg
- (list (read-file-name "Info file name: " nil nil t))))
- (pop-to-buffer "*info*")
+ (interactive (list
+ (if (and current-prefix-arg (not (numberp current-prefix-arg)))
+ (read-file-name "Info file name: " nil nil t))
+ (if (numberp current-prefix-arg)
+ (format "*info*<%s>" current-prefix-arg))))
+ (pop-to-buffer (or buffer "*info*"))
+ (if (and buffer (not (eq major-mode 'Info-mode)))
+ (Info-mode))
(if file
;; If argument already contains parentheses, don't add another set
;; since the argument will then be parsed improperly. This also
@@ -480,7 +492,7 @@ in all the directories in that path."
(Info-goto-node file)
(Info-goto-node (concat "(" file ")")))
(if (zerop (buffer-size))
- (Info-directory))))
+ (Info-directory))))
;;;###autoload
(defun info-emacs-manual ()
@@ -535,11 +547,15 @@ just return nil (no error)."
(if (stringp filename)
(let (temp temp-downcase found)
(setq filename (substitute-in-file-name filename))
- (cond
+ (cond
((string= (downcase filename) "dir")
(setq found t))
((string= filename "apropos")
(setq found 'apropos))
+ ((string= filename "history")
+ (setq found 'history))
+ ((string= filename "toc")
+ (setq found 'toc))
(t
(let ((dirs (if (string-match "^\\./" filename)
;; If specified name starts with `./'
@@ -742,6 +758,10 @@ a case-insensitive match is tried."
(Info-insert-dir))
((eq filename 'apropos)
(insert-buffer-substring " *info-apropos*"))
+ ((eq filename 'history)
+ (insert-buffer-substring " *info-history*"))
+ ((eq filename 'toc)
+ (insert-buffer-substring " *info-toc*"))
(t
(info-insert-file-contents filename nil)
(setq default-directory (file-name-directory filename))))
@@ -782,6 +802,8 @@ a case-insensitive match is tried."
(cond
((eq filename t) "dir")
((eq filename 'apropos) "apropos")
+ ((eq filename 'history) "history")
+ ((eq filename 'toc) "toc")
(t filename)))
))
;; Use string-equal, not equal, to ignore text props.
@@ -842,9 +864,17 @@ a case-insensitive match is tried."
(let ((pos (Info-find-node-in-buffer regexp)))
(when pos
(goto-char pos)
- (throw 'foo t))
- (error "No such anchor in tag table or node in tag table or file: %s"
- nodename)))
+ (throw 'foo t)))
+
+ (when (string-match "\\([^.]+\\)\\." nodename)
+ (let (Info-point-loc)
+ (Info-find-node-2
+ filename (match-string 1 nodename) no-going-back))
+ (widen)
+ (throw 'foo t))
+
+ ;; No such anchor in tag table or node in tag table or file
+ (error "No such node or anchor: %s" nodename))
(Info-select-node)
(goto-char (point-min))
@@ -856,9 +886,12 @@ a case-insensitive match is tried."
(cons new-history
(delete new-history Info-history-list))))
(goto-char anchorpos))
- (Info-reference-name
- (Info-find-index-name Info-reference-name)
- (setq Info-reference-name nil))))))
+ ((numberp Info-point-loc)
+ (forward-line (1- Info-point-loc))
+ (setq Info-point-loc nil))
+ ((stringp Info-point-loc)
+ (Info-find-index-name Info-point-loc)
+ (setq Info-point-loc nil))))))
;; If we did not finish finding the specified node,
;; go back to the previous one.
(or Info-current-node no-going-back (null Info-history)
@@ -982,9 +1015,7 @@ a case-insensitive match is tried."
nodename end)
(re-search-backward "^\^_")
(search-forward "Node: ")
- (setq nodename
- (and (looking-at (Info-following-node-name-re))
- (match-string 1)))
+ (setq nodename (Info-following-node-name))
(search-forward "\n\^_" nil 'move)
(beginning-of-line)
(setq end (point))
@@ -1053,7 +1084,7 @@ a case-insensitive match is tried."
(goto-char (point-min))
;; Remove duplicate headings in the same menu.
(while (search-forward "\n* Menu:" nil t)
- (setq limit (save-excursion (search-forward "\n" nil t)))
+ (setq limit (save-excursion (search-forward "\n\^_" nil t)))
;; Look for the next heading to unify.
(while (re-search-forward "^\\(\\w.*\\)\n\\*" limit t)
(let ((name (match-string 1))
@@ -1264,7 +1295,8 @@ any double quotes or backslashes must be escaped (\\\",\\\\)."
(let ((new-history (list Info-current-file Info-current-node)))
(setq Info-history-list
(cons new-history (delete new-history Info-history-list))))
- (Info-fontify-node)
+ (if (not (eq Info-fontify-maximum-menu-size nil))
+ (Info-fontify-node))
(Info-display-images-node)
(Info-hide-cookies-node)
(run-hooks 'Info-selection-hook)))))
@@ -1284,6 +1316,7 @@ any double quotes or backslashes must be escaped (\\\",\\\\)."
;; Go to an info node specified with a filename-and-nodename string
;; of the sort that is found in pointers in nodes.
+;;;###autoload
(defun Info-goto-node (nodename &optional fork)
"Go to info node named NODENAME. Give just NODENAME or (FILENAME)NODENAME.
If NODENAME is of the form (FILENAME)NODENAME, the node is in the Info file
@@ -1298,8 +1331,6 @@ If FORK is a string, it is the name to use for the new buffer."
(if fork
(set-buffer
(clone-buffer (concat "*info-" (if (stringp fork) fork nodename) "*") t)))
- (if (member (buffer-name) '("*info-history*" "*info-toc*"))
- (switch-to-buffer "*info*"))
(let (filename)
(string-match "\\s *\\((\\s *\\([^\t)]*\\)\\s *)\\s *\\|\\)\\(.*\\)"
nodename)
@@ -1307,9 +1338,9 @@ If FORK is a string, it is the name to use for the new buffer."
""
(match-string 2 nodename))
nodename (match-string 3 nodename))
- (let ((trim (string-match "\\s *\\'" filename)))
+ (let ((trim (string-match "\\s +\\'" filename)))
(if trim (setq filename (substring filename 0 trim))))
- (let ((trim (string-match "\\s *\\'" nodename)))
+ (let ((trim (string-match "\\s +\\'" nodename)))
(if trim (setq nodename (substring nodename 0 trim))))
(if transient-mark-mode (deactivate-mark))
(Info-find-node (if (equal filename "") nil filename)
@@ -1616,75 +1647,63 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(interactive)
(Info-find-node "dir" "top"))
-;;;###autoload (add-hook 'same-window-buffer-names "*info-history*")
-
(defun Info-history ()
- "Create the buffer *info-history* with a menu of visited nodes."
+ "Go to a node with a menu of visited nodes."
(interactive)
(let ((curr-file Info-current-file)
(curr-node Info-current-node)
p)
- (pop-to-buffer
- (with-current-buffer (get-buffer-create "*info-history*")
- (let ((inhibit-read-only t))
- (erase-buffer)
- (goto-char (point-min))
- (insert "Node: History\n\n")
- (insert "Recently Visited Nodes\n**********************\n\n")
- (insert "* Menu:\n\n")
- (let ((hl Info-history-list))
- (while hl
- (let ((file (nth 0 (car hl)))
- (node (nth 1 (car hl))))
- (if (and (string-equal file curr-file)
- (string-equal node curr-node))
- (setq p (point)))
- (insert "* " node ": (" (file-name-nondirectory file)
- ")" node ".\n"))
- (setq hl (cdr hl))))
- (or (eq major-mode 'Info-mode) (Info-mode))
- (setq Info-current-file "info-history")
- (setq Info-current-node "Info History")
- (Info-set-mode-line)
- (if (not (bobp)) (Info-fontify-node))
- (current-buffer))))
+ (with-current-buffer (get-buffer-create " *info-history*")
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (goto-char (point-min))
+ (insert "\n\^_\nFile: history Node: Top, Up: (dir)\n\n")
+ (insert "Recently Visited Nodes\n**********************\n\n")
+ (insert "* Menu:\n\n")
+ (let ((hl (delete '("history" "Top") Info-history-list)))
+ (while hl
+ (let ((file (nth 0 (car hl)))
+ (node (nth 1 (car hl))))
+ (if (and (string-equal file curr-file)
+ (string-equal node curr-node))
+ (setq p (point)))
+ (insert "* " node ": (" (file-name-nondirectory file)
+ ")" node ".\n"))
+ (setq hl (cdr hl))))))
+ (Info-find-node "history" "Top")
(goto-char (or p (point-min)))))
-;;;###autoload (add-hook 'same-window-buffer-names "*info-toc*")
-
(defun Info-toc ()
- "Create the buffer *info-toc* with Info file's table of contents."
+ "Go to a node with table of contents of the current Info file.
+Table of contents is created from the tree structure of menus."
(interactive)
(let ((curr-file Info-current-file)
(curr-node Info-current-node)
p)
- (pop-to-buffer
- (with-current-buffer (get-buffer-create "*info-toc*")
- (if (not (equal Info-current-file curr-file))
- (let ((inhibit-read-only t)
- (node-list (Info-build-toc curr-file)))
- (erase-buffer)
- (goto-char (point-min))
- (insert "Node: Contents\n\n")
- (insert "Table of Contents\n*****************\n\n")
- (insert "*Note Top::\n")
- (Info-insert-toc
- (nth 2 (assoc "Top" node-list)) ; get Top nodes
- node-list 0)
- (or (eq major-mode 'Info-mode) (Info-mode))
- (setq Info-current-file curr-file)
- (setq Info-current-node "Contents")
- (Info-set-mode-line)))
- (if (not (bobp))
- (let ((Info-hide-note-references 'hide))
- (Info-fontify-node)))
- (goto-char (point-min))
- (if (setq p (search-forward (concat "*Note " curr-node "::") nil t))
- (setq p (- p (length curr-node) 2)))
- (current-buffer)))
+ (with-current-buffer (get-buffer-create " *info-toc*")
+ (let ((inhibit-read-only t)
+ (node-list (Info-build-toc curr-file)))
+ (erase-buffer)
+ (goto-char (point-min))
+ (insert "\n\^_\nFile: toc Node: Top, Up: (dir)\n\n")
+ (insert "Table of Contents\n*****************\n\n")
+ (insert "*Note Top::\n")
+ (Info-insert-toc
+ (nth 2 (assoc "Top" node-list)) ; get Top nodes
+ node-list 0 (substring-no-properties curr-file)))
+ (if (not (bobp))
+ (let ((Info-hide-note-references 'hide)
+ (Info-fontify-visited-nodes nil))
+ (Info-mode)
+ (setq Info-current-file "toc" Info-current-node "Top")
+ (Info-fontify-node)))
+ (goto-char (point-min))
+ (if (setq p (search-forward (concat "*Note " curr-node ":") nil t))
+ (setq p (- p (length curr-node) 2))))
+ (Info-find-node "toc" "Top")
(goto-char (or p (point-min)))))
-(defun Info-insert-toc (nodes node-list level)
+(defun Info-insert-toc (nodes node-list level curr-file)
"Insert table of contents with references to nodes."
(let ((section "Top"))
(while nodes
@@ -1692,8 +1711,8 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(unless (member (nth 1 node) (list nil section))
(insert (setq section (nth 1 node)) "\n"))
(insert (make-string level ?\t))
- (insert "*Note " (car nodes) "::\n")
- (Info-insert-toc (nth 2 node) node-list (1+ level))
+ (insert "*Note " (car nodes) ": (" curr-file ")" (car nodes) ".\n")
+ (Info-insert-toc (nth 2 node) node-list (1+ level) curr-file)
(setq nodes (cdr nodes))))))
(defun Info-build-toc (file)
@@ -1701,16 +1720,18 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(if (equal file "dir")
(error "Table of contents for Info directory is not supported yet"))
(with-temp-buffer
- (let ((default-directory (or (and (stringp file)
- (file-name-directory
- (setq file (Info-find-file file))))
- default-directory))
- (sections '(("Top" "Top")))
- nodes subfiles)
- (while (or file subfiles)
- (or file (message "Searching subfile %s..." (car subfiles)))
+ (let* ((default-directory (or (and (stringp file)
+ (file-name-directory
+ (setq file (Info-find-file file))))
+ default-directory))
+ (main-file file)
+ (sections '(("Top" "Top")))
+ nodes subfiles)
+ (while (or main-file subfiles)
+ (or main-file (message "Searching subfile %s..." (car subfiles)))
(erase-buffer)
- (info-insert-file-contents (or file (car subfiles)))
+ (info-insert-file-contents (or main-file (car subfiles)))
+ (goto-char (point-min))
(while (and (search-forward "\n\^_\nFile:" nil 'move)
(search-forward "Node: " nil 'move))
(let ((nodename (substring-no-properties (Info-following-node-name)))
@@ -1718,7 +1739,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(point-max)) 2))
(section "Top")
menu-items)
- (when (and (not (string-match "\\<index\\>" nodename))
+ (when (and (not (Info-index-node nodename file))
(re-search-forward "^\\* Menu:" bound t))
(forward-line 1)
(beginning-of-line)
@@ -1750,7 +1771,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(nreverse menu-items))
nodes))
(goto-char bound)))
- (if file
+ (if main-file
(save-excursion
(goto-char (point-min))
(if (search-forward "\n\^_\nIndirect:" nil t)
@@ -1759,7 +1780,7 @@ If SAME-FILE is non-nil, do not move to a different Info file."
(setq subfiles (cons (match-string-no-properties 1)
subfiles)))))
(setq subfiles (nreverse subfiles)
- file nil))
+ main-file nil))
(setq subfiles (cdr subfiles))))
(message "")
(nreverse nodes))))
@@ -1838,8 +1859,7 @@ new buffer."
(if (and (save-excursion
(goto-char (+ (point) 5)) ; skip a possible *note
(re-search-backward "\\*note[ \n\t]+" nil t)
- (looking-at (concat "\\*note[ \n\t]+"
- (Info-following-node-name-re "^.,\t"))))
+ (looking-at str))
(<= (point) (match-end 0)))
(goto-char (match-beginning 0))))
;; Go to the reference closest to point
@@ -1867,11 +1887,27 @@ new buffer."
Because of ambiguities, this should be concatenated with something like
`:' and `Info-following-node-name-re'.")
-(defun Info-extract-menu-node-name (&optional multi-line)
+(defun Info-extract-menu-node-name (&optional multi-line index-node)
(skip-chars-forward " \t\n")
(when (looking-at (concat Info-menu-entry-name-re ":\\(:\\|"
(Info-following-node-name-re
- (if multi-line "^.,\t" "^.,\t\n")) "\\)"))
+ (cond
+ (index-node "^,\t\n")
+ (multi-line "^.,\t")
+ (t "^.,\t\n")))
+ "\\)"
+ (if index-node
+ "\\.\\(?:[ \t\n]+(line +\\([0-9]+\\))\\)?"
+ "")))
+ (if index-node
+ (setq Info-point-loc
+ (if (match-beginning 5)
+ (string-to-number (match-string 5))
+ (buffer-substring (match-beginning 0) (1- (match-beginning 1)))))
+;;; Comment out the next line to use names of cross-references:
+;;; (setq Info-point-loc
+;;; (buffer-substring (match-beginning 0) (1- (match-beginning 1))))
+ )
(replace-regexp-in-string
"[ \n]+" " "
(or (match-string 2)
@@ -1886,6 +1922,7 @@ Because of ambiguities, this should be concatenated with something like
(defvar Info-complete-menu-buffer)
(defvar Info-complete-next-re nil)
+(defvar Info-complete-nodes nil)
(defvar Info-complete-cache nil)
(defconst Info-node-spec-re
@@ -1899,6 +1936,9 @@ Because of ambiguities, this should be concatenated with something like
;; - `Info-complete-next-re' which, if non-nil, indicates that we should
;; also look for menu items in subsequent nodes as long as those
;; nodes' names match `Info-complete-next-re'. This feature is currently
+ ;; not used.
+ ;; - `Info-complete-nodes' which, if non-nil, indicates that we should
+ ;; also look for menu items in these nodes. This feature is currently
;; only used for completion in Info-index.
;; Note that `Info-complete-menu-buffer' could be current already,
@@ -1922,6 +1962,7 @@ Because of ambiguities, this should be concatenated with something like
(if (and (equal (nth 0 Info-complete-cache) Info-current-file)
(equal (nth 1 Info-complete-cache) Info-current-node)
(equal (nth 2 Info-complete-cache) Info-complete-next-re)
+ (equal (nth 5 Info-complete-cache) Info-complete-nodes)
(let ((prev (nth 3 Info-complete-cache)))
(eq t (compare-strings string 0 (length prev)
prev 0 nil t))))
@@ -1934,9 +1975,12 @@ Because of ambiguities, this should be concatenated with something like
(push (match-string-no-properties 1)
completions))
;; Check subsequent nodes if applicable.
- (and Info-complete-next-re
- (setq nextnode (Info-extract-pointer "next" t))
- (string-match Info-complete-next-re nextnode)))
+ (or (and Info-complete-next-re
+ (setq nextnode (Info-extract-pointer "next" t))
+ (string-match Info-complete-next-re nextnode))
+ (and Info-complete-nodes
+ (setq Info-complete-nodes (cdr Info-complete-nodes)
+ nextnode (car Info-complete-nodes)))))
(Info-goto-node nextnode))
;; Go back to the start node (for the next completion).
(unless (equal Info-current-node orignode)
@@ -1944,7 +1988,8 @@ Because of ambiguities, this should be concatenated with something like
;; Update the cache.
(set (make-local-variable 'Info-complete-cache)
(list Info-current-file Info-current-node
- Info-complete-next-re string completions)))
+ Info-complete-next-re string completions
+ Info-complete-nodes)))
(if action
(all-completions string completions predicate)
(try-completion string completions predicate)))))))
@@ -2013,7 +2058,7 @@ new buffer."
(error "No such item in menu"))
(beginning-of-line)
(forward-char 2)
- (Info-extract-menu-node-name)))))
+ (Info-extract-menu-node-name nil (Info-index-node))))))
;; If COUNT is nil, use the last item in the menu.
(defun Info-extract-menu-counting (count)
@@ -2028,7 +2073,7 @@ new buffer."
(error "Too few items in menu"))
(while (search-forward "\n* " nil t)
nil))
- (Info-extract-menu-node-name)))))
+ (Info-extract-menu-node-name nil (Info-index-node))))))
(defun Info-nth-menu-item ()
"Go to the node of the Nth menu item.
@@ -2055,7 +2100,7 @@ N is the digit argument used to invoke this command."
;; move forward until we can't go any farther.
(while (Info-forward-node t t) nil)
;; Then keep moving down to last subnode, unless we reach an index.
- (while (and (not (string-match "\\<index\\>" Info-current-node))
+ (while (and (not (Info-index-node))
(save-excursion (search-forward "\n* Menu:" nil t)))
(Info-goto-node (Info-extract-menu-counting nil)))))
@@ -2071,7 +2116,7 @@ N is the digit argument used to invoke this command."
;; 3. next node is up and next
(cond ((and (not not-down)
(save-excursion (search-forward "\n* menu:" nil t))
- (not (string-match "\\<index\\>" Info-current-node)))
+ (not (Info-index-node)))
(Info-goto-node (Info-extract-menu-counting 1))
t)
((save-excursion (search-backward "next:" nil t))
@@ -2109,7 +2154,7 @@ N is the digit argument used to invoke this command."
;; go down to find the last subnode*.
(Info-prev)
(let (Info-history)
- (while (and (not (string-match "\\<index\\>" Info-current-node))
+ (while (and (not (Info-index-node))
(save-excursion (search-forward "\n* Menu:" nil t)))
(Info-goto-node (Info-extract-menu-counting nil)))))
(t
@@ -2300,32 +2345,124 @@ parent node."
(if recur
(error "No cross references in this node")
(Info-prev-reference t)))))
+
+(defvar Info-index-nodes nil
+ "Alist of cached index node names of visited Info files.
+Each element has the form (INFO-FILE INDEX-NODE-NAMES-LIST).")
+
+(defun Info-index-nodes (&optional file)
+ "Return a list of names of all index nodes in Info FILE.
+If FILE is omitted, it defaults to the current Info file.
+First look in a list of cached index node names. Then scan Info
+file and its subfiles for nodes with the index cookie. Then try
+to find index nodes starting from the first node in the top level
+menu whose name contains the word \"Index\", plus any immediately
+following nodes whose names also contain the word \"Index\"."
+ (or file (setq file Info-current-file))
+ (or (assoc file Info-index-nodes)
+ ;; Skip virtual Info files
+ (and (member file '("dir" "history" "toc" "apropos"))
+ (setq Info-index-nodes (cons (cons file nil) Info-index-nodes)))
+ (not (stringp file))
+ ;; Find nodes with index cookie
+ (let* ((default-directory (or (and (stringp file)
+ (file-name-directory
+ (setq file (Info-find-file file))))
+ default-directory))
+ Info-history Info-history-list Info-fontify-maximum-menu-size
+ (main-file file) subfiles nodes node)
+ (condition-case nil
+ (with-temp-buffer
+ (while (or main-file subfiles)
+ (erase-buffer)
+ (info-insert-file-contents (or main-file (car subfiles)))
+ (goto-char (point-min))
+ (while (search-forward "\0\b[index\0\b]" nil 'move)
+ (save-excursion
+ (re-search-backward "^\^_")
+ (search-forward "Node: ")
+ (setq nodes (cons (Info-following-node-name) nodes))))
+ (if main-file
+ (save-excursion
+ (goto-char (point-min))
+ (if (search-forward "\n\^_\nIndirect:" nil t)
+ (let ((bound (save-excursion (search-forward "\n\^_" nil t))))
+ (while (re-search-forward "^\\(.*\\): [0-9]+$" bound t)
+ (setq subfiles (cons (match-string-no-properties 1)
+ subfiles)))))
+ (setq subfiles (nreverse subfiles)
+ main-file nil))
+ (setq subfiles (cdr subfiles)))))
+ (error nil))
+ (if nodes
+ (setq nodes (nreverse nodes)
+ Info-index-nodes (cons (cons file nodes) Info-index-nodes)))
+ nodes)
+ ;; Find nodes with the word "Index" in the node name
+ (let ((case-fold-search t)
+ Info-history Info-history-list Info-fontify-maximum-menu-size
+ nodes node)
+ (condition-case nil
+ (with-temp-buffer
+ (Info-mode)
+ (Info-find-node file "Top")
+ (when (and (search-forward "\n* menu:" nil t)
+ (re-search-forward "\n\\* \\(.*\\<Index\\>\\)" nil t))
+ (goto-char (match-beginning 1))
+ (setq nodes (list (Info-extract-menu-node-name)))
+ (Info-goto-node (car nodes))
+ (while (and (setq node (Info-extract-pointer "next" t))
+ (string-match "\\<Index\\>" node))
+ (setq nodes (cons node nodes))
+ (Info-goto-node node))))
+ (error nil))
+ (if nodes
+ (setq nodes (nreverse nodes)
+ Info-index-nodes (cons (cons file nodes) Info-index-nodes)))
+ nodes)
+ ;; If file has no index nodes, still add it to the cache
+ (setq Info-index-nodes (cons (cons file nil) Info-index-nodes)))
+ (cdr (assoc file Info-index-nodes)))
+
+(defun Info-index-node (&optional node file)
+ "Return non-nil value if NODE is an index node.
+If NODE is nil, check the current Info node.
+If FILE is nil, check the current Info file."
+ (if (or (and node (not (equal node Info-current-node)))
+ (assoc (or file Info-current-file) Info-index-nodes))
+ (member (or node Info-current-node) (Info-index-nodes file))
+ ;; Don't search all index nodes if request is only for the current node
+ ;; and file is not in the cache of index nodes
+ (or
+ (save-match-data
+ (string-match "\\<Index\\>" (or node Info-current-node "")))
+ (save-excursion
+ (goto-char (+ (or (save-excursion
+ (search-backward "\n\^_" nil t))
+ (point-min)) 2))
+ (search-forward "\0\b[index\0\b]"
+ (or (save-excursion
+ (search-forward "\n\^_" nil t))
+ (point-max)) t)))))
(defun Info-goto-index ()
- (Info-goto-node "Top")
- (or (search-forward "\n* menu:" nil t)
- (error "No index"))
- (or (re-search-forward "\n\\* \\(.*\\<Index\\>\\)" nil t)
- (error "No index"))
- (goto-char (match-beginning 1))
- ;; Protect Info-history so that the current node (Top) is not added to it.
- (let ((Info-history nil))
- (Info-goto-node (Info-extract-menu-node-name))))
+ "Go to the first index node."
+ (let ((node (car (Info-index-nodes))))
+ (or node (error "No index"))
+ (Info-goto-node node)))
;;;###autoload
(defun Info-index (topic)
"Look up a string TOPIC in the index for this file.
-The index is defined as the first node in the top level menu whose
-name contains the word \"Index\", plus any immediately following
-nodes whose names also contain the word \"Index\".
If there are no exact matches to the specified topic, this chooses
the first match which is a case-insensitive substring of a topic.
-Use the `,' command to see the other matches.
+Use the \\<Info-mode-map>\\[Info-index-next] command to see the other matches.
Give a blank topic name to go to the Index node itself."
(interactive
(list
(let ((Info-complete-menu-buffer (clone-buffer))
- (Info-complete-next-re "\\<Index\\>"))
+ (Info-complete-nodes (Info-index-nodes))
+ (Info-history-list nil))
(if (equal Info-current-file "dir")
(error "The Info directory node has no index; use m to select a manual"))
(unwind-protect
@@ -2336,9 +2473,10 @@ Give a blank topic name to go to the Index node itself."
(if (equal Info-current-file "dir")
(error "The Info directory node has no index; use m to select a manual"))
(let ((orignode Info-current-node)
- (pattern (format "\n\\* +\\([^\n]*%s[^\n]*\\):[ \t]+\\([^.\n]*\\)\\.[ \t]*\\([0-9]*\\)"
+ (pattern (format "\n\\* +\\([^\n]*%s[^\n]*\\):[ \t]+\\([^\n]*\\)\\.\\(?:[ \t\n]*(line +\\([0-9]+\\))\\)?"
(regexp-quote topic)))
- node
+ node (nodes (Info-index-nodes))
+ (ohist-list Info-history-list)
(case-fold-search t))
(Info-goto-index)
(or (equal topic "")
@@ -2360,8 +2498,7 @@ Give a blank topic name to go to the Index node itself."
(string-to-number (concat "0"
(match-string 3))))
matches))
- (and (setq node (Info-extract-pointer "next" t))
- (string-match "\\<Index\\>" node)))
+ (setq nodes (cdr nodes) node (car nodes)))
(Info-goto-node node))
(or matches
(progn
@@ -2371,11 +2508,12 @@ Give a blank topic name to go to the Index node itself."
(while (setq found (assoc topic matches))
(setq exact (cons found exact)
matches (delq found matches)))
+ (setq Info-history-list ohist-list)
(setq Info-index-alternatives (nconc exact (nreverse matches)))
(Info-index-next 0)))))
(defun Info-index-next (num)
- "Go to the next matching index item from the last `i' command."
+ "Go to the next matching index item from the last \\<Info-mode-map>\\[Info-index] command."
(interactive "p")
(or Info-index-alternatives
(error "No previous `i' command"))
@@ -2388,7 +2526,7 @@ Give a blank topic name to go to the Index node itself."
num (1- num)))
(Info-goto-node (nth 1 (car Info-index-alternatives)))
(if (> (nth 3 (car Info-index-alternatives)) 0)
- (forward-line (nth 3 (car Info-index-alternatives)))
+ (forward-line (1- (nth 3 (car Info-index-alternatives))))
(forward-line 3) ; don't search in headers
(let ((name (car (car Info-index-alternatives))))
(Info-find-index-name name)))
@@ -2427,16 +2565,14 @@ Give a blank topic name to go to the Index node itself."
Build a menu of the possible matches."
(interactive "sIndex apropos: ")
(unless (string= string "")
- (let ((pattern (format "\n\\* +\\([^\n]*%s[^\n]*\\):[ \t]+\\([^.]+\\)."
+ (let ((pattern (format "\n\\* +\\([^\n]*%s[^\n]*\\):[ \t]+\\([^\n]+\\)\\.\\(?:[ \t\n]*(line +\\([0-9]+\\))\\)?"
(regexp-quote string)))
(ohist Info-history)
(ohist-list Info-history-list)
(current-node Info-current-node)
(current-file Info-current-file)
- manuals matches temp-file node)
- (let ((Info-fontify-maximum-menu-size 0)
- Info-use-header-lines
- Info-hide-note-references)
+ manuals matches node nodes)
+ (let ((Info-fontify-maximum-menu-size nil))
(Info-directory)
(message "Searching indices...")
(goto-char (point-min))
@@ -2445,24 +2581,22 @@ Build a menu of the possible matches."
(add-to-list 'manuals (match-string 1)))
(dolist (manual manuals)
(message "Searching %s" manual)
- (condition-case nil
- (save-excursion
- (Info-find-node manual "Top")
- (when (re-search-forward "\n\\* \\(.*\\<Index\\>\\)" nil t)
- (goto-char (match-beginning 1))
- (Info-goto-node (Info-extract-menu-node-name))
- (while
- (progn
- (goto-char (point-min))
- (while (re-search-forward pattern nil t)
- (add-to-list 'matches
- (list (match-string 1)
- (match-string 2)
- manual)))
- (and (setq node (Info-extract-pointer "next" t))
- (string-match "\\<Index\\>" node)))
- (Info-goto-node node))))
- (error nil))))
+ (if (setq nodes (Info-index-nodes (Info-find-file manual)))
+ (condition-case nil
+ (save-excursion
+ (Info-find-node manual (car nodes))
+ (while
+ (progn
+ (goto-char (point-min))
+ (while (re-search-forward pattern nil t)
+ (add-to-list 'matches
+ (list manual
+ (match-string-no-properties 1)
+ (match-string-no-properties 2)
+ (match-string-no-properties 3))))
+ (setq nodes (cdr nodes) node (car nodes)))
+ (Info-goto-node node)))
+ (error nil)))))
(Info-goto-node (concat "(" current-file ")" current-node))
(setq Info-history ohist
Info-history-list ohist-list)
@@ -2471,12 +2605,19 @@ Build a menu of the possible matches."
(message "No matches found")
(with-current-buffer (get-buffer-create " *info-apropos*")
(erase-buffer)
- (insert "\n\nFile: apropos, Node: Top, Up: (dir)\n")
+ (insert "\n\^_\nFile: apropos, Node: Index, Up: (dir)\n")
(insert "* Menu: \nNodes whose indices contain \"" string "\"\n\n")
(dolist (entry matches)
- (insert "* " (car entry) " [" (nth 2 entry)
- "]: (" (nth 2 entry) ")" (nth 1 entry) ".\n")))
- (Info-find-node "apropos" "top")))))
+ (insert
+ (format "* %-38s (%s)%s.%s\n"
+ (concat (nth 1 entry) " [" (nth 0 entry) "]:")
+ (nth 0 entry)
+ (nth 2 entry)
+ (if (nth 3 entry)
+ (concat " (line " (nth 3 entry) ")")
+ "")))))
+ (Info-find-node "apropos" "Index")
+ (setq Info-complete-cache nil)))))
(defun Info-undefined ()
"Make command be undefined in Info."
@@ -2592,21 +2733,15 @@ if point is in a menu item description, follow that menu item."
(browse-url (browse-url-url-at-point)))
((setq node (Info-get-token (point) "\\*note[ \n\t]+"
"\\*note[ \n\t]+\\([^:]*\\):\\(:\\|[ \n\t]*(\\)?"))
-;;; (or (match-string 2)
-;;; (setq Info-reference-name
-;;; (replace-regexp-in-string
-;;; "[ \n\t]+" " " (match-string-no-properties 1))))
(Info-follow-reference node fork))
;; menu item: node name
((setq node (Info-get-token (point) "\\* +" "\\* +\\([^:]*\\)::"))
(Info-goto-node node fork))
- ;; menu item: index entry
+ ;; menu item: node name or index entry
((Info-get-token (point) "\\* +" "\\* +\\(.*\\): ")
- (if (save-match-data (string-match "\\<index\\>" Info-current-node))
- (setq Info-reference-name (match-string-no-properties 1)))
(beginning-of-line)
(forward-char 2)
- (setq node (Info-extract-menu-node-name))
+ (setq node (Info-extract-menu-node-name nil (Info-index-node)))
(Info-goto-node node fork))
((setq node (Info-get-token (point) "Up: " "Up: \\([^,\n\t]*\\)"))
(Info-goto-node node fork))
@@ -2654,16 +2789,21 @@ if point is in a menu item description, follow that menu item."
(define-key Info-mode-map "h" 'Info-help)
(define-key Info-mode-map "i" 'Info-index)
(define-key Info-mode-map "l" 'Info-last)
+ (define-key Info-mode-map "L" 'Info-history)
(define-key Info-mode-map "m" 'Info-menu)
(define-key Info-mode-map "n" 'Info-next)
(define-key Info-mode-map "p" 'Info-prev)
(define-key Info-mode-map "q" 'Info-exit)
(define-key Info-mode-map "s" 'Info-search)
+ (define-key Info-mode-map "S" 'Info-search-case-sensitively)
;; For consistency with Rmail.
(define-key Info-mode-map "\M-s" 'Info-search)
(define-key Info-mode-map "\M-n" 'clone-buffer)
(define-key Info-mode-map "t" 'Info-top-node)
+ (define-key Info-mode-map "T" 'Info-toc)
(define-key Info-mode-map "u" 'Info-up)
+ ;; For consistency with dired-copy-filename-as-kill.
+ (define-key Info-mode-map "w" 'Info-copy-current-node-name)
(define-key Info-mode-map "," 'Info-index-next)
(define-key Info-mode-map "\177" 'Info-scroll-down)
(define-key Info-mode-map [mouse-2] 'Info-mouse-follow-nearest-node)
@@ -2708,9 +2848,9 @@ if point is in a menu item description, follow that menu item."
["Last" Info-last :active Info-history
:help "Go to the last node you were at"]
["History" Info-history :active Info-history-list
- :help "Go to the history buffer"]
+ :help "Go to menu of visited nodes"]
["Table of Contents" Info-toc
- :help "Go to the buffer with a table of contents"]
+ :help "Go to table of contents"]
("Index..."
["Lookup a String" Info-index
:help "Look for a string in the index items"]
@@ -2808,20 +2948,23 @@ if point is in a menu item description, follow that menu item."
(error (ding))))
-(defun Info-copy-current-node-name ()
+(defun Info-copy-current-node-name (&optional arg)
"Put the name of the current info node into the kill ring.
-The name of the info file is prepended to the node name in parentheses."
- (interactive)
+The name of the info file is prepended to the node name in parentheses.
+With a zero prefix arg, put the name inside a function call to `info'."
+ (interactive "P")
(unless Info-current-node
(error "No current info node"))
- (kill-new
- (concat "("
- (file-name-nondirectory
- (if (stringp Info-current-file)
- Info-current-file
- (or buffer-file-name "")))
- ")"
- Info-current-node)))
+ (let ((node (concat "(" (file-name-nondirectory
+ (or (and (stringp Info-current-file)
+ Info-current-file)
+ buffer-file-name
+ ""))
+ ")" Info-current-node)))
+ (if (zerop (prefix-numeric-value arg))
+ (setq node (concat "(info \"" node "\")")))
+ (kill-new node)
+ (message "%s" node)))
;; Info mode is suitable only for specially formatted data.
@@ -2852,14 +2995,15 @@ Selecting other nodes:
\\[Info-directory] Go to the Info directory node.
\\[Info-follow-reference] Follow a cross reference. Reads name of reference.
\\[Info-last] Move to the last node you were at.
-\\[Info-history] Go to the history buffer.
-\\[Info-toc] Go to the buffer with a table of contents.
-\\[Info-index] Look up a topic in this file's Index and move to that node.
-\\[Info-index-next] (comma) Move to the next match from a previous `i' command.
+\\[Info-history] Go to menu of visited nodes.
+\\[Info-toc] Go to table of contents of the current Info file.
\\[Info-top-node] Go to the Top node of this file.
\\[Info-final-node] Go to the final node in this file.
\\[Info-backward-node] Go backward one node, considering all nodes as forming one sequence.
\\[Info-forward-node] Go forward one node, considering all nodes as forming one sequence.
+\\[Info-index] Look up a topic in this file's Index and move to that node.
+\\[Info-index-next] (comma) Move to the next match from a previous \\<Info-mode-map>\\[Info-index] command.
+\\[info-apropos] Look for a string in the indices of all manuals.
Moving within a node:
\\[Info-scroll-up] Normally, scroll forward a full screen.
@@ -2876,17 +3020,17 @@ Advanced commands:
\\[Info-copy-current-node-name] Put name of current info node in the kill ring.
\\[clone-buffer] Select a new cloned Info buffer in another window.
\\[Info-edit] Edit contents of selected node.
-1 Pick first item in node's menu.
-2, 3, 4, 5 Pick second ... fifth item in node's menu.
+1 .. 9 Pick first ... ninth item in node's menu.
+ Every third `*' is highlighted to help pick the right number.
\\[Info-goto-node] Move to node specified by name.
You may include a filename as well, as (FILENAME)NODENAME.
\\[universal-argument] \\[info] Move to new Info file with completion.
+\\[universal-argument] N \\[info] Select Info buffer with prefix number in the name *info*<N>.
\\[Info-search] Search through this Info file for specified regexp,
and select the node in which the next occurrence is found.
-\\[Info-search-case-sensitively] Search through this Info file
- for specified regexp case-sensitively.
+\\[Info-search-case-sensitively] Search through this Info file for specified regexp case-sensitively.
\\[Info-search-next] Search for another occurrence of regexp
- from a previous `Info-search' command.
+ from a previous \\<Info-mode-map>\\[Info-search] command.
\\[Info-next-reference] Move cursor to next cross-reference or menu item.
\\[Info-prev-reference] Move cursor to previous cross-reference or menu item."
(kill-all-local-variables)
@@ -2916,6 +3060,8 @@ Advanced commands:
;; This is for the sake of the invisible text we use handling titles.
(make-local-variable 'line-move-ignore-invisible)
(setq line-move-ignore-invisible t)
+ (make-local-variable 'desktop-save-buffer)
+ (setq desktop-save-buffer 'Info-desktop-buffer-misc-data)
(add-hook 'clone-buffer-hook 'Info-clone-buffer-hook nil t)
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
(Info-set-mode-line)
@@ -3045,8 +3191,9 @@ The locations are of the format used in `Info-history', i.e.
;; Bind Info-history to nil, to prevent the index nodes from
;; getting into the node history.
(let ((Info-history nil)
- node)
- (Info-goto-node (Info-extract-menu-node-name))
+ (Info-history-list nil)
+ node (nodes (Info-index-nodes)))
+ (Info-goto-node (car nodes))
(while
(progn
(goto-char (point-min))
@@ -3056,8 +3203,7 @@ The locations are of the format used in `Info-history', i.e.
(match-string-no-properties 2)
0)
where)))
- (and (setq node (Info-extract-pointer "next" t))
- (string-match "\\<Index\\>" node)))
+ (and (setq nodes (cdr nodes) node (car nodes))))
(Info-goto-node node)))
where))
@@ -3080,13 +3226,11 @@ COMMAND must be a symbol or string."
;; Get Info running, and pop to it in another window.
(save-window-excursion
(info))
- ;; FIXME It would be cool if this could use a buffer other
- ;; than *info*.
- (pop-to-buffer "*info*")
+ (or (eq major-mode 'Info-mode) (pop-to-buffer "*info*"))
;; Bind Info-history to nil, to prevent the last Index node
;; visited by Info-find-emacs-command-nodes from being
;; pushed onto the history.
- (let ((Info-history nil))
+ (let ((Info-history nil) (Info-history-list nil))
(Info-find-node (car (car where))
(car (cdr (car where)))))
(if (> num-matches 1)
@@ -3122,26 +3266,26 @@ the variable `Info-file-list-for-emacs'."
(Info-goto-emacs-command-node command)))))
(defface Info-title-1-face
- '((((type tty pc) (class color)) (:foreground "yellow" :weight bold))
- (t (:height 1.2 :inherit Info-title-2-face)))
+ '((((type tty pc) (class color)) :foreground "yellow" :weight bold)
+ (t :height 1.2 :inherit Info-title-2-face))
"Face for Info titles at level 1."
:group 'info)
(defface Info-title-2-face
- '((((type tty pc) (class color)) (:foreground "lightblue" :weight bold))
- (t (:height 1.2 :inherit Info-title-3-face)))
+ '((((type tty pc) (class color)) :foreground "lightblue" :weight bold)
+ (t :height 1.2 :inherit Info-title-3-face))
"Face for Info titles at level 2."
:group 'info)
(defface Info-title-3-face
- '((((type tty pc) (class color)) (:weight bold))
- (t (:height 1.2 :inherit Info-title-4-face)))
+ '((((type tty pc) (class color)) :weight bold)
+ (t :height 1.2 :inherit Info-title-4-face))
"Face for Info titles at level 3."
:group 'info)
(defface Info-title-4-face
- '((((type tty pc) (class color)) (:weight bold))
- (t (:weight bold :inherit variable-pitch)))
+ '((((type tty pc) (class color)) :weight bold)
+ (t :weight bold :inherit variable-pitch))
"Face for Info titles at level 4."
:group 'info)
@@ -3360,7 +3504,8 @@ Preserve text properties."
(hl Info-history-list)
res)
(if (string-match "(\\([^)]+\\))\\([^)]*\\)" node)
- (setq file (match-string 1 node)
+ (setq file (file-name-nondirectory
+ (match-string 1 node))
node (if (equal (match-string 2 node) "")
"Top"
(match-string 2 node))))
@@ -3377,14 +3522,20 @@ Preserve text properties."
(add-text-properties (match-beginning 3) (match-end 3)
'(invisible t front-sticky nil rear-nonsticky t))
;; Unhide the file name of the external reference in parens
- (if (match-string 6)
+ (if (and (match-string 6) (not (eq Info-hide-note-references 'hide)))
(remove-text-properties (match-beginning 6) (match-end 6)
'(invisible t front-sticky nil rear-nonsticky t)))
;; Unhide newline because hidden newlines cause too long lines
(save-match-data
- (let ((start3 (match-beginning 3)))
- (if (string-match "\n[ \t]*" (match-string 3))
- (remove-text-properties (+ start3 (match-beginning 0)) (+ start3 (match-end 0))
+ (let ((beg3 (match-beginning 3))
+ (end3 (match-end 3)))
+ (if (and (string-match "\n[ \t]*" (match-string 3))
+ (not (save-match-data
+ (save-excursion
+ (goto-char (1+ end3))
+ (looking-at "[.)]*$")))))
+ (remove-text-properties (+ beg3 (match-beginning 0))
+ (+ beg3 (match-end 0))
'(invisible t front-sticky nil rear-nonsticky t))))))
(when (and Info-refill-paragraphs Info-hide-note-references)
(push (set-marker (make-marker) start)
@@ -3416,7 +3567,7 @@ Preserve text properties."
(goto-char (point-min))
(when (and (or not-fontified-p fontify-visited-p)
(search-forward "\n* Menu:" nil t)
- (not (string-match "\\<Index\\>" Info-current-node))
+ (not (Info-index-node))
;; Don't take time to annotate huge menus
(< (- (point-max) (point)) Info-fontify-maximum-menu-size))
(let ((n 0)
@@ -3454,7 +3605,8 @@ Preserve text properties."
(hl Info-history-list)
res)
(if (string-match "(\\([^)]+\\))\\([^)]*\\)" node)
- (setq file (match-string 1 node)
+ (setq file (file-name-nondirectory
+ (match-string 1 node))
node (if (equal (match-string 2 node) "")
"Top"
(match-string 2 node))))
@@ -3502,6 +3654,13 @@ Preserve text properties."
(put-text-property (match-beginning 1) (match-end 1)
'font-lock-face 'info-menu-header)))
+ ;; Hide index line numbers
+ (goto-char (point-min))
+ (when (and not-fontified-p (Info-index-node))
+ (while (re-search-forward "[ \t\n]*(line +[0-9]+)" nil t)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'invisible t)))
+
;; Fontify http and ftp references
(goto-char (point-min))
(when not-fontified-p
@@ -3713,6 +3872,27 @@ BUFFER is the buffer speedbar is requesting buttons for."
"^No \".*\" in index$"))
(add-to-list 'debug-ignored-errors mess))
+;;;; Desktop support
+
+(defun Info-desktop-buffer-misc-data (desktop-dirname)
+ "Auxiliary information to be saved in desktop file."
+ (if (not (member Info-current-file '("apropos" "history" "toc")))
+ (list Info-current-file Info-current-node)))
+
+;;;###autoload
+(defun Info-restore-desktop-buffer (desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ "Restore an info buffer specified in a desktop file."
+ (let ((first (nth 0 desktop-buffer-misc))
+ (second (nth 1 desktop-buffer-misc)))
+ (when (and first second)
+ (when desktop-buffer-name
+ (set-buffer (get-buffer-create desktop-buffer-name))
+ (Info-mode))
+ (Info-find-node first second)
+ (current-buffer))))
+
(provide 'info)
;;; arch-tag: f2480fe2-2139-40c1-a49b-6314991164ac
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el
index 883b53d83e3..6dd0258e6c5 100644
--- a/lisp/international/ccl.el
+++ b/lisp/international/ccl.el
@@ -1120,7 +1120,8 @@
(insert (format "write r%d (%d remaining)\n" rrr cc)))
(defun ccl-dump-call (ignore cc)
- (insert (format "call subroutine #%d\n" cc)))
+ (let ((subroutine (car (ccl-get-next-code))))
+ (insert (format "call subroutine `%s'\n" subroutine))))
(defun ccl-dump-write-const-string (rrr cc)
(if (= rrr 0)
diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el
index cd60e266b45..4c93ee62554 100644
--- a/lisp/international/mule-cmds.el
+++ b/lisp/international/mule-cmds.el
@@ -1030,7 +1030,7 @@ For a list of useful values for KEY and their meanings,
see `language-info-alist'."
(if (symbolp lang-env)
(setq lang-env (symbol-name lang-env)))
- (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
+ (let ((lang-slot (assoc-string lang-env language-info-alist t)))
(if lang-slot
(cdr (assq key (cdr lang-slot))))))
@@ -1587,11 +1587,11 @@ to using the function `set-language-environment'."
:link '(custom-manual "(emacs)Language Environments")
:set (lambda (symbol value) (set-language-environment value))
:get (lambda (x)
- (or (car-safe (assoc-ignore-case
+ (or (car-safe (assoc-string
(if (symbolp current-language-environment)
(symbol-name current-language-environment)
current-language-environment)
- language-info-alist))
+ language-info-alist t))
"English"))
;; custom type will be updated with `set-language-info'.
:type (if language-info-alist
@@ -1696,7 +1696,7 @@ specifies the character set for the major languages of Western Europe."
(if (symbolp language-name)
(setq language-name (symbol-name language-name)))
(setq language-name "English"))
- (let ((slot (assoc-ignore-case language-name language-info-alist)))
+ (let ((slot (assoc-string language-name language-info-alist t)))
(unless slot
(error "Language environment not defined: %S" language-name))
(setq language-name (car slot)))
@@ -1860,8 +1860,8 @@ Setting this variable directly does not take effect. See
?3))
;; We suppress these setting for the moment because the
;; above assumption is wrong.
- ;; (aset standard-display-table ?' [?,F"(B])
- ;; (aset standard-display-table ?` [?,F!(B])
+ ;; (aset standard-display-table ?' [?$B!G(B])
+ ;; (aset standard-display-table ?` [?$B!F(B])
;; The fonts don't have the relevant bug.
(aset standard-display-table 160 nil)
(aset standard-display-table (make-char 'latin-iso8859-1 160)
@@ -2268,7 +2268,7 @@ matches are looked for in the coding system list, treating case and
the characters `-' and `_' as insignificant. The coding system base
is returned. Thus, for instance, if charset \"ISO8859-2\",
`iso-latin-2' is returned."
- (or (car (assoc-ignore-case charset locale-charset-alist))
+ (or (car (assoc-string charset locale-charset-alist t))
(let ((cs coding-system-alist)
c)
(while (and (not c) cs)
@@ -2413,6 +2413,16 @@ See also `locale-charset-language-names', `locale-language-names',
(message "Warning: Default coding system `%s' disagrees with
system codeset `%s' for this locale." coding-system codeset))))))))
+ ;; On Windows, override locale-coding-system, keyboard-coding-system,
+ ;; selection-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)
+ (setq locale-coding-system code-page-coding)
+ (set-selection-coding-system code-page-coding)
+ (set-keyboard-coding-system code-page-coding)
+ (set-terminal-coding-system code-page-coding))))
+
;; Default to A4 paper if we're not in a C, POSIX or US locale.
;; (See comments in Flocale_info.)
(let ((locale locale)
@@ -2435,7 +2445,11 @@ system codeset `%s' for this locale." coding-system codeset))))))))
("posix$" . letter)
(".._us" . letter)
(".._pr" . letter)
- (".._ca" . letter)))
+ (".._ca" . letter)
+ ("enu$" . letter) ; Windows
+ ("esu$" . letter)
+ ("enc$" . letter)
+ ("frc$" . letter)))
'a4))))))
nil)
diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el
index 18d477c1cb8..2ce49981cf2 100644
--- a/lisp/international/mule-diag.el
+++ b/lisp/international/mule-diag.el
@@ -965,9 +965,7 @@ see the function `describe-fontset' for the format of the list."
(goto-char (point-min))
(while (re-search-forward
"^ \\([^ ]+\\) (`.*' in mode line)$" nil t)
- (help-xref-button 1 #'help-input-method
- (match-string 1)
- "mouse-2: describe this method"))))))
+ (help-xref-button 1 'help-input-method (match-string 1)))))))
(defun list-input-methods-1 ()
(if (not input-method-alist)
diff --git a/lisp/international/mule-util.el b/lisp/international/mule-util.el
index c3ea76c8716..9751812f348 100644
--- a/lisp/international/mule-util.el
+++ b/lisp/international/mule-util.el
@@ -379,27 +379,7 @@ basis, this may not be accurate."
;; On a window system, a character is displayable if we have
;; a font for that character in the default face of the
;; currently selected frame.
- (let ((fontset (frame-parameter (selected-frame) 'font))
- font-pattern)
- (if (query-fontset fontset)
- (setq font-pattern (fontset-font fontset char)))
- (or font-pattern
- (setq font-pattern (fontset-font "fontset-default" char)))
- (if font-pattern
- (progn
- ;; Now FONT-PATTERN is a string or a cons of family
- ;; field pattern and registry field pattern.
- (or (stringp font-pattern)
- (let ((family (or (car font-pattern) "*"))
- (registry (or (cdr font-pattern) "*")))
- (or (string-match "-" family)
- (setq family (concat "*-" family)))
- (or (string-match "-" registry)
- (setq registry (concat registry "-*")))
- (setq font-pattern
- (format "-%s-*-*-*-*-*-*-*-*-*-*-%s"
- family registry))))
- (x-list-fonts font-pattern 'default (selected-frame) 1)))))
+ (car (internal-char-font nil char)))
(t
(let ((coding (terminal-coding-system)))
(if coding
diff --git a/lisp/international/mule.el b/lisp/international/mule.el
index 8b2702bc30a..32f6a199268 100644
--- a/lisp/international/mule.el
+++ b/lisp/international/mule.el
@@ -1374,9 +1374,9 @@ Each element must be one of the names listed in the variable
(let* ((M (char-after (+ pos 4)))
(L (char-after (+ pos 5)))
(encoding (match-string 2))
- (encoding-info (assoc-ignore-case
+ (encoding-info (assoc-string
encoding
- ctext-non-standard-encodings-alist))
+ ctext-non-standard-encodings-alist t))
(coding (if encoding-info
(nth 1 encoding-info)
(setq encoding (intern (downcase encoding)))
@@ -1418,7 +1418,7 @@ Each element must be one of the names listed in the variable
(dolist (elt charset)
(aset table (make-char elt) slot)))
((char-table-p charset)
- (map-char-table #'(lambda (k v)
+ (map-char-table #'(lambda (k v)
(if (and v (> k 128)) (aset table k slot)))
charset))))))
table))
@@ -1467,7 +1467,7 @@ text, and convert it in the temporary buffer. Otherwise, convert in-place."
(- (point) last-pos)))
(save-excursion
(goto-char last-pos)
- (insert (string-to-multibyte
+ (insert (string-to-multibyte
(format "\e%%/%d%c%c%s"
noctets
(+ (/ len 128) 128)
@@ -1636,7 +1636,7 @@ function by default."
(goto-char tail-start)
(re-search-forward "[\r\n]\^L" nil t)
(if (re-search-forward
- "[\r\n]\\([^[\r\n]*\\)[ \t]*Local Variables:[ \t]*\\([^\r\n]*\\)[\r\n]"
+ "[\r\n]\\([^[\r\n]*\\)[ \t]*Local Variables:[ \t]*\\([^\r\n]*\\)[\r\n]"
tail-end t)
;; The prefix is what comes before "local variables:" in its
;; line. The suffix is what comes after "local variables:"
@@ -1656,7 +1656,7 @@ function by default."
"[ \t]*unibyte[ \t]*:[ \t]*\\([^ \t\r\n]+\\)[ \t]*"
suffix "[\r\n]"))
(re-end
- (concat "[\r\n]" prefix "[ \t]*End *:[ \t]*" suffix
+ (concat "[\r\n]" prefix "[ \t]*End *:[ \t]*" suffix
"[\r\n]?"))
(pos (1- (point))))
(forward-char -1) ; skip back \r or \n.
diff --git a/lisp/international/quail.el b/lisp/international/quail.el
index 1415648be3b..2feaaeabf20 100644
--- a/lisp/international/quail.el
+++ b/lisp/international/quail.el
@@ -1043,9 +1043,13 @@ which to install MAP.
The installed decode map can be referred by the function `quail-decode-map'."
(if (null quail-current-package)
(error "No current Quail package"))
- (if (not (and (consp decode-map) (eq (car decode-map) 'decode-map)))
- (error "Invalid Quail decode map `%s'" decode-map))
- (setcar (nthcdr 10 quail-current-package) decode-map))
+ (if (if (consp decode-map)
+ (eq (car decode-map) 'decode-map)
+ (if (char-table-p decode-map)
+ (eq (char-table-subtype decode-map) 'quail-decode-map)))
+ (setcar (nthcdr 10 quail-current-package) decode-map)
+ (error "Invalid Quail decode map `%s'" decode-map)))
+
;;;###autoload
(defun quail-defrule (key translation &optional name append)
@@ -1218,7 +1222,7 @@ selected translation."
(t
(error "Invalid object in Quail map: %s" def))))
-(defun quail-lookup-key (key &optional len)
+(defun quail-lookup-key (key &optional len not-reset-indices)
"Lookup KEY of length LEN in the current Quail map and return the definition.
The returned value is a Quail map specific to KEY."
(or len
@@ -1256,7 +1260,7 @@ The returned value is a Quail map specific to KEY."
(if (and (consp translation) (vectorp (cdr translation)))
(progn
(setq quail-current-translations translation)
- (if (quail-forget-last-selection)
+ (if (and (not not-reset-indices) (quail-forget-last-selection))
(setcar (car quail-current-translations) 0))))))
;; We may have to reform cdr part of MAP.
(if (and (cdr map) (functionp (cdr map)))
@@ -1512,6 +1516,28 @@ with more keys."
(let (pos)
(quail-delete-region)
(setq pos (point))
+ (or enable-multibyte-characters
+ (let (char)
+ (if (stringp quail-current-str)
+ (catch 'tag
+ (mapc #'(lambda (ch)
+ (when (/= (unibyte-char-to-multibyte
+ (multibyte-char-to-unibyte ch))
+ ch)
+ (setq char ch)
+ (throw 'tag nil)))
+ quail-current-str))
+ (if (/= (unibyte-char-to-multibyte
+ (multibyte-char-to-unibyte quail-current-str))
+ quail-current-str)
+ (setq char quail-current-str)))
+ (when char
+ (message "Can't input %c in the current unibyte buffer" char)
+ (ding)
+ (sit-for 2)
+ (message nil)
+ (setq quail-current-str nil)
+ (throw 'quail-tag nil))))
(insert quail-current-str)
(move-overlay quail-overlay pos (point))
(if (overlayp quail-conv-overlay)
@@ -2009,7 +2035,7 @@ minibuffer and the selected frame has no other windows)."
(defun quail-get-translations ()
"Return a string containing the current possible translations."
- (let ((map (quail-lookup-key quail-current-key))
+ (let ((map (quail-lookup-key quail-current-key nil t))
(str (copy-sequence quail-current-key)))
(if quail-current-translations
(quail-update-current-translations))
@@ -2080,7 +2106,7 @@ are shown (at most to the depth specified `quail-completion-max-depth')."
(quail-setup-completion-buf)
(let ((win (get-buffer-window quail-completion-buf 'visible))
(key quail-current-key)
- (map (quail-lookup-key quail-current-key))
+ (map (quail-lookup-key quail-current-key nil t))
(require-update nil))
(with-current-buffer quail-completion-buf
(if (and win
@@ -2556,6 +2582,143 @@ KEY BINDINGS FOR CONVERSION
(quail-update-guidance)
))))
+;; Add KEY (string) to the element of TABLE (char-table) for CHAR if
+;; it is not yet stored. As a result, the element is a string or a
+;; list of strings.
+
+(defsubst quail-store-decode-map-key (table char key)
+ (let ((elt (aref table char)))
+ (if elt
+ (if (consp elt)
+ (or (member key elt)
+ (aset table char (cons key elt)))
+ (or (string= key elt)
+ (aset table char (list key elt))))
+ (aset table char key))))
+
+;; Helper function for quail-gen-decode-map. Store key strings to
+;; type each character under MAP in TABLE (char-table). MAP is an
+;; element of the current Quail map reached by typing keys in KEY
+;; (string).
+
+(defun quail-gen-decode-map1 (map key table)
+ (when (and (consp map) (listp (cdr map)))
+ (let ((trans (car map)))
+ (cond ((integerp trans)
+ (quail-store-decode-map-key table trans key))
+ ((stringp trans)
+ (dotimes (i (length trans))
+ (quail-store-decode-map-key table (aref trans i) key)))
+ ((or (vectorp trans)
+ (and (consp trans)
+ (setq trans (cdr trans))))
+ (dotimes (i (length trans))
+ (let ((elt (aref trans i)))
+ (if (stringp elt)
+ (if (= (length elt) 1)
+ (quail-store-decode-map-key table (aref elt 0) key))
+ (quail-store-decode-map-key table elt key)))))))
+ (if (> (length key) 1)
+ (dolist (elt (cdr map))
+ (quail-gen-decode-map1 (cdr elt) key table))
+ (dolist (elt (cdr map))
+ (quail-gen-decode-map1 (cdr elt) (format "%s%c" key (car elt))
+ table)))))
+
+(put 'quail-decode-map 'char-table-extra-slots 0)
+
+;; Generate a halfly-cooked decode map (char-table) for the current
+;; Quail map. An element for a character C is a key string or a list
+;; of a key strings to type to input C. The lenth of key string is at
+;; most 2. If it is 2, more keys may be required to input C.
+
+(defun quail-gen-decode-map ()
+ (let ((table (make-char-table 'quail-decode-map nil)))
+ (dolist (elt (cdr (quail-map)))
+ (quail-gen-decode-map1 (cdr elt) (string (car elt)) table))
+ table))
+
+;; Helper function for quail-find-key. Prepend key strings to type
+;; for inputting CHAR by the current input method to KEY-LIST and
+;; return the result. MAP is an element of the current Quail map
+;; reached by typing keys in KEY.
+
+(defun quail-find-key1 (map key char key-list)
+ (let ((trans (car map))
+ (found-here nil))
+ (cond ((stringp trans)
+ (setq found-here
+ (and (= (length trans) 1) (= (aref trans 0) char))))
+ ((or (vectorp trans) (consp trans))
+ (if (consp trans)
+ (setq trans (cdr trans)))
+ (setq found-here
+ (catch 'tag
+ (dotimes (i (length trans))
+ (let ((target (aref trans i)))
+ (if (integerp target)
+ (if (= target char)
+ (throw 'tag t))
+ (if (and (= (length target) 1)
+ (= (aref target 0) char))
+ (throw 'tag t))))))))
+ ((integerp trans)
+ (if (= trans char)
+ (setq found-here t))))
+ (if found-here
+ (setq key-list (cons key key-list)))
+ (if (> (length key) 1)
+ (dolist (elt (cdr map))
+ (setq key-list
+ (quail-find-key1 (cdr elt) (format "%s%c" key (car elt))
+ char key-list))))
+ key-list))
+
+(defun quail-find-key (char)
+ "Return a list of keys to type to input CHAR in the current input method.
+If CHAR is an ASCII character and can be input by typing itself, return t."
+ (let ((decode-map (or (quail-decode-map)
+ (setcar (nthcdr 10 quail-current-package)
+ (quail-gen-decode-map))))
+ (key-list nil))
+ (if (consp decode-map)
+ (let ((str (string char)))
+ (mapc #'(lambda (elt)
+ (if (string= str (car elt))
+ (setq key-list (cons (cdr elt) key-list))))
+ (cdr decode-map)))
+ (let ((key-head (aref decode-map char)))
+ (if (stringp key-head)
+ (setq key-list (quail-find-key1
+ (quail-lookup-key key-head nil t)
+ key-head char nil))
+ (mapc #'(lambda (elt)
+ (setq key-list
+ (quail-find-key1
+ (quail-lookup-key elt nil t) elt char key-list)))
+ key-head))))
+ (or key-list
+ (and (< char 128)
+ (not (quail-lookup-key (string char) 1))))))
+
+(defun quail-show-key ()
+ "Show a list of key strings to type for inputting a character at point."
+ (interactive)
+ (or current-input-method
+ (error "No input method is activated"))
+ (let* ((char (following-char))
+ (key-list (quail-find-key char)))
+ (cond ((consp key-list)
+ (message "To input `%c', type \"%s\""
+ char
+ (mapconcat 'identity key-list "\", \"")))
+ ((eq key-list t)
+ (message "To input `%s', just type it"
+ (single-key-description char)))
+ (t
+ (message "%c can't be input by the current input method" char)))))
+
+
;; Quail map generator from state transition table.
(defun quail-map-from-table (table)
@@ -2661,7 +2824,7 @@ function `quail-install-map' (which see)."
(translation-list nil)
map)
(while (> len 0)
- (setq map (quail-lookup-key key len)
+ (setq map (quail-lookup-key key len t)
len (1- len))
(if map
(let* ((def (quail-map-definition map))
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index d92e28981e3..2891dcca52d 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -1112,21 +1112,25 @@ the generated Quail package is saved."
name title dicfile coding quailfile converter copyright
dicbuf)
(while tail
- (when (or (string-match (nth 2 (car tail)) filename)
- ;; MS-DOS filesystem truncates file names to 8+3
- ;; limits, so "cangjie-table.cns" becomes
- ;; "cangjie-.cns", and the above string-match fails.
- ;; Give DOS users a chance...
- (and (fboundp 'msdos-long-file-names)
- (not (msdos-long-file-names))
- (string-match (dos-8+3-filename (nth 2 (car tail)))
- filename)))
- (setq slot (car tail)
- name (car slot)
+ (setq slot (car tail)
+ dicfile (nth 2 slot)
+ quailfile (nth 4 slot))
+ (when (and (or (string-match dicfile filename)
+ ;; MS-DOS filesystem truncates file names to 8+3
+ ;; limits, so "cangjie-table.cns" becomes
+ ;; "cangjie-.cns", and the above string-match
+ ;; fails. Give DOS users a chance...
+ (and (fboundp 'msdos-long-file-names)
+ (not (msdos-long-file-names))
+ (string-match (dos-8+3-filename dicfile) filename)))
+ (if (file-newer-than-file-p
+ filename (expand-file-name quailfile dirname))
+ t
+ (message "%s is up to date" quailfile)
+ nil))
+ (setq name (car slot)
title (nth 1 slot)
- dicfile (nth 2 slot)
coding (nth 3 slot)
- quailfile (nth 4 slot)
converter (nth 5 slot)
copyright (nth 6 slot))
(message "Converting %s to %s..." dicfile quailfile)
diff --git a/lisp/isearch.el b/lisp/isearch.el
index f9729567169..4d86b37cb8d 100644
--- a/lisp/isearch.el
+++ b/lisp/isearch.el
@@ -444,12 +444,15 @@ With a prefix argument, do an incremental regular expression search instead.
As you type characters, they add to the search string and are found.
The following non-printing keys are bound in `isearch-mode-map'.
-Type \\[isearch-delete-char] to cancel characters from end of search string.
+Type \\[isearch-delete-char] to cancel last input item from end of search string.
+Type \\[isearch-del-char] to cancel last character from end of search string.
Type \\[isearch-exit] to exit, leaving point at location found.
Type LFD (C-j) to match end of line.
Type \\[isearch-repeat-forward] to search again forward,\
\\[isearch-repeat-backward] to search again backward.
-Type \\[isearch-yank-word-or-char] to yank word from buffer onto end of search\
+Type \\[isearch-yank-char] to yank character from buffer onto end of search\
+ string and search for it.
+Type \\[isearch-yank-word] to yank word from buffer onto end of search\
string and search for it.
Type \\[isearch-yank-line] to yank rest of line onto end of search string\
and search for it.
@@ -482,7 +485,7 @@ To use a different input method for searching, type
you want to use.
The above keys, bound in `isearch-mode-map', are often controlled by
- options; do M-x apropos on search-.* to find them.
+ options; do \\[apropos] on search-.* to find them.
Other control and meta characters terminate the search
and are then executed normally (depending on `search-exit-option').
Likewise for function keys and mouse button events.
@@ -785,7 +788,7 @@ The following additional command keys are active while editing.
\\[isearch-ring-retreat-edit] to replace the search string with the previous item in the search ring.
\\[isearch-complete-edit] to complete the search string using the search ring.
\\<isearch-mode-map>
-If first char entered is \\[isearch-yank-word-or-char], then do word search instead."
+If first char entered is \\[isearch-yank-word], then do word search instead."
;; This code is very hairy for several reasons, explained in the code.
;; Mainly, isearch-mode must be terminated while editing and then restarted.
@@ -992,7 +995,8 @@ Use `isearch-exit' to quit without signaling."
(if (equal isearch-string "")
(setq isearch-success t)
- (if (and isearch-success (equal (match-end 0) (match-beginning 0))
+ (if (and isearch-success
+ (equal (point) isearch-other-end)
(not isearch-just-started))
;; If repeating a search that found
;; an empty string, ensure we advance.
@@ -1049,6 +1053,16 @@ If no previous match was done, just beep."
(isearch-pop-state))
(isearch-update))
+(defun isearch-del-char ()
+ "Discard last character and move point back.
+If there is no previous character, just beep."
+ (interactive)
+ (if (equal isearch-string "")
+ (ding)
+ (setq isearch-string (substring isearch-string 0 -1)
+ isearch-message (mapconcat 'isearch-text-char-description
+ isearch-string "")))
+ (isearch-search-and-update))
(defun isearch-yank-string (string)
"Pull STRING into search string."
@@ -1110,7 +1124,7 @@ might return the position of the end of the line."
(buffer-substring-no-properties (point) (funcall jumpform)))))
(defun isearch-yank-char ()
- "Pull next letter from buffer into search string."
+ "Pull next character from buffer into search string."
(interactive)
(isearch-yank-internal (lambda () (forward-char 1) (point))))
@@ -1138,9 +1152,8 @@ might return the position of the end of the line."
(defun isearch-search-and-update ()
;; Do the search and update the display.
(when (or isearch-success
- ;; unsuccessful regexp search may become
- ;; successful by addition of characters which
- ;; make isearch-string valid
+ ;; Unsuccessful regexp search may become successful by
+ ;; addition of characters which make isearch-string valid
isearch-regexp
;; If the string was found but was completely invisible,
;; it might now be partly visible, so try again.
@@ -1467,7 +1480,9 @@ Isearch mode."
(command-execute scroll-command)
(let ((ab-bel (isearch-string-out-of-window isearch-point)))
(if ab-bel
- (isearch-back-into-window (eq ab-bel 'above) isearch-point)))
+ (isearch-back-into-window (eq ab-bel 'above) isearch-point)
+ (or (eq (point) isearch-point)
+ (goto-char isearch-point))))
(isearch-update))
(search-exit-option
(let (window)
@@ -1746,7 +1761,13 @@ If there is no completion possible, say so and continue searching."
(let ((cursor-in-echo-area ellipsis)
(m (concat
(isearch-message-prefix c-q-hack ellipsis isearch-nonincremental)
- isearch-message
+ (if (and (not isearch-success)
+ (string-match " +$" isearch-message))
+ (concat
+ (substring isearch-message 0 (match-beginning 0))
+ (propertize (substring isearch-message (match-beginning 0))
+ 'face 'trailing-whitespace))
+ isearch-message)
(isearch-message-suffix c-q-hack ellipsis)
)))
(if c-q-hack
@@ -1793,7 +1814,11 @@ If there is no completion possible, say so and continue searching."
;; Searching
-(defvar isearch-search-fun-function nil "Override `isearch-function-fun'.")
+(defvar isearch-search-fun-function nil
+ "Override `isearch-search-fun'.
+This function should return the search function for isearch to use.
+It will call this function with three arguments
+as if it were `search-forward'.")
(defun isearch-search-fun ()
"Return the function to use for the search.
diff --git a/lisp/isearchb.el b/lisp/isearchb.el
new file mode 100644
index 00000000000..9714701944f
--- /dev/null
+++ b/lisp/isearchb.el
@@ -0,0 +1,227 @@
+;;; isearchb --- a marriage between iswitchb and isearch
+
+;; Copyright (C) 2004 John Wiegley
+
+;; Author: John Wiegley <johnw@gnu.org>
+;; Created: 16 Apr 2004
+;; Version: 1.5
+;; Keywords: lisp
+;; X-URL: http://www.newartisans.com/johnw/emacs.html
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This module allows you to switch to buffers even faster than with
+;; iswitchb! It is not intended to replace it, however, as it works
+;; well only with buffers whose names don't typically overlap. You'll
+;; have to try it first, and see how your mileage varies.
+;;
+;; The first way to use isearchb is by holding down a modifier key, in
+;; which case every letter you type while holding it searches for any
+;; buffer matching what you're typing (using the same ordering scheme
+;; employed by iswitchb). To use it this way, add to your .emacs:
+;;
+;; (isearchb-set-keybindings 'super) ; s-x s-y s-z now finds "xyz"
+;;
+;; The other way is by using a command that puts you into "search"
+;; mode, just like with isearch. I use C-z for this. The binding in
+;; my .emacs looks like:
+;;
+;; (define-key global-map [(control ?z)] 'isearchb-activate)
+;;
+;; Now, after pressing C-z (for example), each self-inserting
+;; character thereafter will search for a buffer containing those
+;; characters. For instance, typing "C-z xyz" will switch to the
+;; first buffer containing "xyz". Once you press a non-self-inserting
+;; character (such as any control key sequence), the search will end.
+;;
+;; C-z after C-z toggles between the previously selected buffer and
+;; the current one.
+;;
+;; C-g aborts the search and returns you to your original buffer.
+;;
+;; TAB, after typing in a few characters (after C-z), will jump into
+;; iswitchb, using the prefix you've typed so far. This is handy when
+;; you realize that isearchb is not powerful enough to find the buffer
+;; you're looking for.
+;;
+;; C-s and C-r move forward and backward in the buffer list. If
+;; `isearchb-show-completions' is non-nil (the default), the list of
+;; possible completions is shown in the minibuffer.
+;;
+;; If `isearchb-idle-timeout' is set to a number, isearchb will quit
+;; after that many seconds of idle time. I recommend trying it set to
+;; one or two seconds. Then, if you switch to a buffer and wait for
+;; that amount of time, you can start typing without manually exiting
+;; isearchb.
+
+;; TODO:
+;; C-z C-z is broken
+;; killing iswitchb.el and then trying to switch back is broken
+;; make sure TAB isn't broken
+
+(require 'iswitchb)
+
+(defgroup isearchb nil
+ "Switch between buffers using a mechanism like isearch."
+ :group 'iswitchb)
+
+(defcustom isearchb-idle-timeout nil
+ "*Number of idle seconds before isearchb turns itself off.
+If nil, don't use a timeout."
+ :type '(choice (integer :tag "Seconds")
+ (const :tag "Disable" nil))
+ :group 'isearchb)
+
+(defcustom isearchb-show-completions t
+ "*If non-nil, show possible completions in the minibuffer."
+ :type 'boolean
+ :group 'isearchb)
+
+(defvar isearchb-start-buffer nil)
+(defvar isearchb-last-buffer nil)
+(defvar isearchb-idle-timer nil)
+
+(defun isearchb-stop (&optional return-to-buffer ignore-command)
+ "Called by isearchb to terminate a search in progress."
+ (remove-hook 'pre-command-hook 'isearchb-follow-char)
+ (if return-to-buffer
+ (switch-to-buffer isearchb-start-buffer)
+ (setq isearchb-last-buffer isearchb-start-buffer))
+ (when isearchb-idle-timer
+ (cancel-timer isearchb-idle-timer)
+ (setq isearchb-idle-timer nil))
+ (if ignore-command
+ (setq this-command 'ignore
+ last-command 'ignore))
+ (message nil))
+
+(defun isearchb-iswitchb ()
+ "isearchb's custom version of the `iswitchb' command.
+It's purpose is to pass different call arguments to
+`iswitchb-read-buffer'."
+ (interactive)
+ (let* ((prompt "iswitch ")
+ (iswitchb-method 'samewindow)
+ (buf (iswitchb-read-buffer prompt nil nil iswitchb-text t)))
+ (if (eq iswitchb-exit 'findfile)
+ (call-interactively 'find-file)
+ (when buf
+ (if (get-buffer buf)
+ ;; buffer exists, so view it and then exit
+ (iswitchb-visit-buffer buf)
+ ;; else buffer doesn't exist
+ (iswitchb-possible-new-buffer buf))))))
+
+(defun isearchb ()
+ "Switch to buffer matching a substring, based on chars typed."
+ (interactive)
+ (unless (eq last-command 'isearchb)
+ (setq iswitchb-text nil))
+ (unless iswitchb-text
+ (setq iswitchb-text "")
+ (iswitchb-make-buflist nil))
+ (if last-command-char
+ (setq iswitchb-rescan t
+ iswitchb-text (concat iswitchb-text
+ (char-to-string last-command-char))))
+ (iswitchb-set-matches)
+ (let* ((match (car iswitchb-matches))
+ (buf (and match (get-buffer match))))
+ (if (null buf)
+ (progn
+ (isearchb-stop t)
+ (isearchb-iswitchb))
+ (switch-to-buffer buf)
+ (if isearchb-show-completions
+ (message "isearchb: %s%s" iswitchb-text
+ (iswitchb-completions iswitchb-text nil))
+ (if (= 1 (length iswitchb-matches))
+ (message "isearchb: %s (only match)" iswitchb-text)
+ (message "isearchb: %s" iswitchb-text))))))
+
+(defun isearchb-set-keybindings (modifier)
+ "Setup isearchb on the given MODIFIER."
+ (dotimes (i 128)
+ (if (eq 'self-insert-command
+ (lookup-key global-map (vector i)))
+ (define-key global-map (vector (list modifier i)) 'isearchb))))
+
+(defun isearchb-follow-char ()
+ "Function added to post-command-hook to handle the isearchb \"mode\"."
+ (let (keys)
+ (if (not (and (memq last-command '(isearchb isearchb-activate))
+ (setq keys (this-command-keys))
+ (= 1 (length keys))))
+ (isearchb-stop)
+ (cond
+ ((or (equal keys "\C-h") (equal keys "\C-?")
+ (equal keys [backspace]) (equal keys [delete]))
+ (setq iswitchb-text
+ (substring iswitchb-text 0 (1- (length iswitchb-text))))
+ (if (= 0 (length iswitchb-text))
+ (isearchb-stop t t)
+ (setq last-command-char nil)
+ (setq this-command 'isearchb)))
+ ((or (equal keys "\C-i") (equal keys [tab]))
+ (setq this-command 'isearchb-iswitchb))
+ ((equal keys "\C-s")
+ (iswitchb-next-match)
+ (setq last-command-char nil)
+ (setq this-command 'isearchb))
+ ((equal keys "\C-r")
+ (iswitchb-prev-match)
+ (setq last-command-char nil)
+ (setq this-command 'isearchb))
+ ((equal keys "\C-g")
+ (ding)
+ (isearchb-stop t t))
+ ((eq (lookup-key global-map keys) 'self-insert-command)
+ (setq this-command 'isearchb)))
+ (if (and isearchb-idle-timeout
+ (null isearchb-idle-timer))
+ (setq isearchb-idle-timer
+ (run-with-idle-timer isearchb-idle-timeout nil
+ 'isearchb-stop))))))
+
+;;;###autoload
+(defun isearchb-activate ()
+ "Active isearchb mode for subsequent alphanumeric keystrokes.
+Executing this command again will terminate the search; or, if
+the search has not yet begun, will toggle to the last buffer
+accessed via isearchb."
+ (interactive)
+ (cond
+ ((eq last-command 'isearchb)
+ (isearchb-stop nil t))
+ ((eq last-command 'isearchb-activate)
+ (if isearchb-last-buffer
+ (switch-to-buffer isearchb-last-buffer)
+ (error "isearchb: There is no previous buffer to toggle to."))
+ (isearchb-stop nil t))
+ (t
+ (message "isearchb: ")
+ (setq iswitchb-text nil
+ isearchb-start-buffer (current-buffer))
+ (add-hook 'pre-command-hook 'isearchb-follow-char))))
+
+(provide 'isearchb)
+
+;;; arch-tag: 9277523f-a624-4aa0-ba10-b89eeb7b6e99
+;;; isearchb.el ends here
diff --git a/lisp/iswitchb.el b/lisp/iswitchb.el
index aab768387d0..bda0ce4fddc 100644
--- a/lisp/iswitchb.el
+++ b/lisp/iswitchb.el
@@ -298,6 +298,29 @@ example functions that filter buffernames."
:type '(repeat (choice regexp function))
:group 'iswitchb)
+(defcustom iswitchb-max-to-show nil
+ "*If non-nil, limit the number of names shown in the minibuffer.
+If this value is N, and N is greater than the number of matching
+buffers, the first N/2 and the last N/2 matching buffers are
+shown. This can greatly speed up iswitchb if you have a
+multitude of buffers open."
+ :type '(choice (const :tag "Show all" nil) integer)
+ :group 'iswitchb)
+
+(defcustom iswitchb-use-virtual-buffers nil
+ "*If non-nil, refer to past buffers when none match.
+This feature relies upon the `recentf' package, which will be
+enabled if this variable is configured to a non-nil value."
+ :type 'boolean
+ :require 'recentf
+ :set (function
+ (lambda (sym value)
+ (if value (recentf-mode 1))
+ (set sym value)))
+ :group 'iswitchb)
+
+(defvar iswitchb-virtual-buffers nil)
+
(defcustom iswitchb-cannot-complete-hook 'iswitchb-completion-help
"*Hook run when `iswitchb-complete' can't complete any more.
The most useful values are `iswitchb-completion-help', which pops up a
@@ -455,7 +478,7 @@ interfere with other minibuffer usage.")
(substitute-key-definition 'display-buffer ; C-x 4 C-o
'iswitchb-display-buffer map global-map)
map)
- "Global keymap for `iswtichb-mode'.")
+ "Global keymap for `iswitchb-mode'.")
(defvar iswitchb-history nil
"History of buffers selected using `iswitchb-buffer'.")
@@ -562,13 +585,18 @@ in a separate window.
(iswitchb-possible-new-buffer buf)))
))))
-;;;###autoload
-(defun iswitchb-read-buffer (prompt &optional default require-match)
+(defun iswitchb-read-buffer (prompt &optional default require-match
+ start matches-set)
"Replacement for the built-in `read-buffer'.
Return the name of a buffer selected.
-PROMPT is the prompt to give to the user. DEFAULT if given is the default
-buffer to be selected, which will go to the front of the list.
-If REQUIRE-MATCH is non-nil, an existing-buffer must be selected."
+PROMPT is the prompt to give to the user.
+DEFAULT if given is the default buffer to be selected, which will
+go to the front of the list.
+If REQUIRE-MATCH is non-nil, an existing-buffer must be selected.
+If START is a string, the selection process is started with that
+string.
+If MATCHES-SET is non-nil, the buflist is not updated before
+the selection process begins. Used by isearchb.el."
(let
(
buf-sel
@@ -581,14 +609,15 @@ If REQUIRE-MATCH is non-nil, an existing-buffer must be selected."
(iswitchb-define-mode-map)
(setq iswitchb-exit nil)
- (setq iswitchb-rescan t)
- (setq iswitchb-text "")
(setq iswitchb-default
(if (bufferp default)
(buffer-name default)
default))
- (iswitchb-make-buflist iswitchb-default)
- (iswitchb-set-matches)
+ (setq iswitchb-text (or start ""))
+ (unless matches-set
+ (setq iswitchb-rescan t)
+ (iswitchb-make-buflist iswitchb-default)
+ (iswitchb-set-matches))
(let
((minibuffer-local-completion-map iswitchb-mode-map)
;; Record the minibuffer depth that we expect to find once
@@ -597,32 +626,41 @@ If REQUIRE-MATCH is non-nil, an existing-buffer must be selected."
(iswitchb-require-match require-match))
;; prompt the user for the buffer name
(setq iswitchb-final-text (completing-read
- prompt ;the prompt
+ prompt ;the prompt
'(("dummy" . 1)) ;table
- nil ;predicate
- nil ;require-match [handled elsewhere]
- nil ;initial-contents
+ nil ;predicate
+ nil ;require-match [handled elsewhere]
+ start ;initial-contents
'iswitchb-history)))
(if (and (not (eq iswitchb-exit 'usefirst))
(get-buffer iswitchb-final-text))
;; This happens for example if the buffer was chosen with the mouse.
- (setq iswitchb-matches (list iswitchb-final-text)))
+ (setq iswitchb-matches (list iswitchb-final-text)
+ iswitchb-virtual-buffers nil))
+
+ ;; If no buffer matched, but a virtual buffer was selected, visit
+ ;; that file now and act as though that buffer had been selected.
+ (if (and iswitchb-virtual-buffers
+ (not (iswitchb-existing-buffer-p)))
+ (let ((virt (car iswitchb-virtual-buffers)))
+ (find-file-noselect (cdr virt))
+ (setq iswitchb-matches (list (car virt))
+ iswitchb-virtual-buffers nil)))
;; Handling the require-match must be done in a better way.
- (if (and require-match (not (iswitchb-existing-buffer-p)))
+ (if (and require-match
+ (not (iswitchb-existing-buffer-p)))
(error "Must specify valid buffer"))
- (if (or
- (eq iswitchb-exit 'takeprompt)
- (null iswitchb-matches))
+ (if (or (eq iswitchb-exit 'takeprompt)
+ (null iswitchb-matches))
(setq buf-sel iswitchb-final-text)
;; else take head of list
(setq buf-sel (car iswitchb-matches)))
;; Or possibly choose the default buffer
(if (equal iswitchb-final-text "")
- (setq buf-sel
- (car iswitchb-matches)))
+ (setq buf-sel (car iswitchb-matches)))
buf-sel))
@@ -723,18 +761,29 @@ If no buffer exactly matching the prompt exists, maybe create a new one."
(setq iswitchb-exit 'findfile)
(exit-minibuffer))
+(eval-when-compile
+ (defvar recentf-list))
+
(defun iswitchb-next-match ()
"Put first element of `iswitchb-matches' at the end of the list."
(interactive)
(let ((next (cadr iswitchb-matches)))
- (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist next))
+ (if (and (null next) iswitchb-virtual-buffers)
+ (setq recentf-list
+ (iswitchb-chop recentf-list
+ (cdr (cadr iswitchb-virtual-buffers))))
+ (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist next)))
(setq iswitchb-rescan t)))
(defun iswitchb-prev-match ()
"Put last element of `iswitchb-matches' at the front of the list."
(interactive)
(let ((prev (car (last iswitchb-matches))))
- (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist prev))
+ (if (and (null prev) iswitchb-virtual-buffers)
+ (setq recentf-list
+ (iswitchb-chop recentf-list
+ (cdr (car (last iswitchb-virtual-buffers)))))
+ (setq iswitchb-buflist (iswitchb-chop iswitchb-buflist prev)))
(setq iswitchb-rescan t)))
(defun iswitchb-chop (list elem)
@@ -826,7 +875,8 @@ current frame, rather than all frames, regardless of value of
(setq iswitchb-matches
(let* ((buflist iswitchb-buflist))
(iswitchb-get-matched-buffers iswitchb-text iswitchb-regexp
- buflist)))))
+ buflist))
+ iswitchb-virtual-buffers nil)))
(defun iswitchb-get-matched-buffers (regexp
&optional string-format buffer-list)
@@ -1064,7 +1114,6 @@ If BUFFER is visible in the current frame, return nil."
(get-buffer-window buffer 0) ; better than 'visible
)))
-;;;###autoload
(defun iswitchb-default-keybindings ()
"Set up default keybindings for `iswitchb-buffer'.
Call this function to override the normal bindings. This function also
@@ -1078,7 +1127,6 @@ Obsolescent. Use `iswitchb-mode'."
(global-set-key "\C-x4\C-o" 'iswitchb-display-buffer)
(global-set-key "\C-x5b" 'iswitchb-buffer-other-frame))
-;;;###autoload
(defun iswitchb-buffer ()
"Switch to another buffer.
@@ -1091,7 +1139,6 @@ For details of keybindings, do `\\[describe-function] iswitchb'."
(setq iswitchb-method iswitchb-default-method)
(iswitchb))
-;;;###autoload
(defun iswitchb-buffer-other-window ()
"Switch to another buffer and show it in another window.
The buffer name is selected interactively by typing a substring.
@@ -1100,7 +1147,6 @@ For details of keybindings, do `\\[describe-function] iswitchb'."
(setq iswitchb-method 'otherwindow)
(iswitchb))
-;;;###autoload
(defun iswitchb-display-buffer ()
"Display a buffer in another window but don't select it.
The buffer name is selected interactively by typing a substring.
@@ -1109,7 +1155,6 @@ For details of keybindings, do `\\[describe-function] iswitchb'."
(setq iswitchb-method 'display)
(iswitchb))
-;;;###autoload
(defun iswitchb-buffer-other-frame ()
"Switch to another buffer and show it in another frame.
The buffer name is selected interactively by typing a substring.
@@ -1185,6 +1230,19 @@ Copied from `icomplete-exhibit' with two changes:
contents
(not minibuffer-completion-confirm)))))))
+(eval-when-compile
+ (defvar most-len)
+ (defvar most-is-exact))
+
+(defun iswitchb-output-completion (com)
+ (if (= (length com) most-len)
+ ;; Most is one exact match,
+ ;; note that and leave out
+ ;; for later indication:
+ (ignore
+ (setq most-is-exact t))
+ (substring com most-len)))
+
(defun iswitchb-completions (name require-match)
"Return the string that is displayed after the user's text.
Modified from `icomplete-completions'."
@@ -1209,6 +1267,35 @@ Modified from `icomplete-completions'."
first)
(setq comps (cons first (cdr comps)))))
+ ;; If no buffers matched, and virtual buffers are being used, then
+ ;; consult the list of past visited files, to see if we can find
+ ;; the file which the user might thought was still open.
+ (when (and iswitchb-use-virtual-buffers (null comps)
+ recentf-list)
+ (setq iswitchb-virtual-buffers nil)
+ (let ((head recentf-list) name)
+ (while head
+ (if (and (setq name (file-name-nondirectory (car head)))
+ (string-match (if iswitchb-regexp
+ iswitchb-text
+ (regexp-quote iswitchb-text)) name)
+ (null (get-file-buffer (car head)))
+ (not (assoc name iswitchb-virtual-buffers))
+ (not (iswitchb-ignore-buffername-p name))
+ (file-exists-p (car head)))
+ (setq iswitchb-virtual-buffers
+ (cons (cons name (car head))
+ iswitchb-virtual-buffers)))
+ (setq head (cdr head)))
+ (setq iswitchb-virtual-buffers (nreverse iswitchb-virtual-buffers)
+ comps (mapcar 'car iswitchb-virtual-buffers))
+ (let ((comp comps))
+ (while comp
+ (put-text-property 0 (length (car comp))
+ 'face 'font-lock-builtin-face
+ (car comp))
+ (setq comp (cdr comp))))))
+
(cond ((null comps) (format " %sNo match%s"
open-bracket-determined
close-bracket-determined))
@@ -1224,28 +1311,28 @@ Modified from `icomplete-completions'."
"")
(if (not iswitchb-use-fonts) " [Matched]")))
(t ;multiple matches
+ (if (and iswitchb-max-to-show
+ (> (length comps) iswitchb-max-to-show))
+ (setq comps
+ (append
+ (let ((res nil)
+ (comp comps)
+ (end (/ iswitchb-max-to-show 2)))
+ (while (>= (setq end (1- end)) 0)
+ (setq res (cons (car comp) res)
+ comp (cdr comp)))
+ (nreverse res))
+ (list "...")
+ (nthcdr (- (length comps)
+ (/ iswitchb-max-to-show 2)) comps))))
(let* (
;;(most (try-completion name candidates predicate))
(most nil)
(most-len (length most))
most-is-exact
(alternatives
- (apply
- (function concat)
- (cdr (apply
- (function nconc)
- (mapcar '(lambda (com)
- (if (= (length com) most-len)
- ;; Most is one exact match,
- ;; note that and leave out
- ;; for later indication:
- (progn
- (setq most-is-exact t)
- ())
- (list ","
- (substring com
- most-len))))
- comps))))))
+ (mapconcat (if most 'iswitchb-output-completion
+ 'identity) comps ",")))
(concat
diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el
index 7e03ed40dda..1806d79f2de 100644
--- a/lisp/language/chinese.el
+++ b/lisp/language/chinese.el
@@ -87,6 +87,7 @@
(define-coding-system-alias 'euc-cn 'chinese-iso-8bit)
(define-coding-system-alias 'cn-gb 'chinese-iso-8bit)
(define-coding-system-alias 'gb2312 'chinese-iso-8bit)
+(define-coding-system-alias 'cp936 'chinese-iso-8bit)
(define-coding-system 'chinese-hz
"Hz/ZW 7-bit encoding for Chinese GB2312 (MIME:HZ-GB-2312)."
@@ -124,6 +125,7 @@
(define-coding-system-alias 'big5 'chinese-big5)
(define-coding-system-alias 'cn-big5 'chinese-big5)
+(define-coding-system-alias 'cp950 'chinese-big5)
(set-language-info-alist
"Chinese-BIG5" '((charset chinese-big5-1 chinese-big5-2)
diff --git a/lisp/language/european.el b/lisp/language/european.el
index 4c12f1bf591..164d51c9aad 100644
--- a/lisp/language/european.el
+++ b/lisp/language/european.el
@@ -43,7 +43,7 @@
(unibyte-display . iso-latin-1)
(input-method . "latin-1-prefix")
(sample-text
- . "Hello, Hej, Tere, Hei, Bonjour, Gr,A|_(B Gott, Ciao, ,A!(BHola!")
+ . "Hello, Hej, Tere, Hei, Bonjour, Gr$(D+d)N(B Gott, Ciao, $(D"B(BHola!")
(documentation . "\
This language environment is a generic one for the Latin-1 (ISO-8859-1)
character set which supports the following European languages:
@@ -241,7 +241,7 @@ See also the Turkish environment."))
(unibyte-display . iso-latin-8)
(input-method . "latin-8-prefix")
;; Fixme: Welsh/Ga{e}lic greetings
- (sample-text . ",_"(B ,_p(B ,_^(B")
+ (sample-text . ",_"(B $(D+q(B $(D*t(B")
(documentation . "\
This language environment is a generic one for the Latin-8 (ISO-8859-14)
character set which supports the Celtic languages, including those not
@@ -271,7 +271,7 @@ covered by other ISO-8859 character sets:
(unibyte-display . iso-latin-9)
(input-method . "latin-9-prefix")
(sample-text
- . "AVE. ,B)9.>,b<=,_/(B ,b$(B")
+ . "AVE. $(D*^+^*v+v)-)M*s(B $(Q)!(B")
(documentation . "\
This language environment is a generic one for the Latin-9 (ISO-8859-15)
character set which supports the same languages as Latin-1 with the
@@ -406,7 +406,7 @@ but it selects the Dutch tutorial and input method."))
(unibyte-display . iso-latin-1)
(sample-text . "\
German (Deutsch Nord) Guten Tag
-German (Deutsch S,A|(Bd) Gr,A|_(B Gott")
+German (Deutsch S$(D+d(Bd) Gr$(D+d)N(B Gott")
(documentation . "\
This language environment is almost the same as Latin-1,
but sets the default input method to \"german-postfix\".
@@ -421,7 +421,7 @@ Additionally, it selects the German tutorial."))
(nonascii-translation . iso-8859-1)
(unibyte-display . iso-latin-1)
(input-method . "latin-1-prefix")
- (sample-text . "French (Fran,Ag(Bais) Bonjour, Salut")
+ (sample-text . "French (Fran$(D+.(Bais) Bonjour, Salut")
(documentation . "\
This language environment is almost the same as Latin-1,
but it selects the French tutorial and input method."))
@@ -450,7 +450,7 @@ Additionally, it selects the Italian tutorial."))
(input-method . "slovenian")
(unibyte-display . iso-8859-2)
(tutorial . "TUTORIAL.sl")
- (sample-text . ",B.(Belimo vam uspe,B9(Ben dan!")
+ (sample-text . "$(D*v(Belimo vam uspe$(D+^(Ben dan!")
(documentation . "\
This language environment is almost the same as Latin-2,
but it selects the Slovenian tutorial and input method."))
@@ -464,7 +464,7 @@ but it selects the Slovenian tutorial and input method."))
(input-method . "spanish-postfix")
(nonascii-translation . iso-8859-1)
(unibyte-display . iso-latin-1)
- (sample-text . "Spanish (Espa,Aq(Bol) ,A!(BHola!")
+ (sample-text . "Spanish (Espa$(D+P(Bol) $(D"B(BHola!")
(documentation . "\
This language environment is almost the same as Latin-1,
but it sets the default input method to \"spanish-postfix\",
@@ -483,19 +483,19 @@ and it selects the Spanish tutorial."))
(nonascii-translation . iso-8859-9)
(unibyte-display . iso-latin-5)
(input-method . "turkish-postfix")
- (sample-text . "Turkish (T,A|(Brk,Ag(Be) Merhaba")
+ (sample-text . "Turkish (T$(D+d(Brk$(D+.(Be) Merhaba")
(setup-function
. (lambda ()
- (set-case-syntax-pair ?I ?,C9(B (standard-case-table))
- (set-case-syntax-pair ?,C)(B ?i (standard-case-table))))
+ (set-case-syntax-pair ?I ?$(D)E(B (standard-case-table))
+ (set-case-syntax-pair ?$(D*D(B ?i (standard-case-table))))
(exit-function
. (lambda ()
(set-case-syntax-pair ?I ?i (standard-case-table))
- (set-case-syntax ?,C9(B "w" (standard-case-table))
- (set-case-syntax ?,C)(B "w" (standard-case-table))))
+ (set-case-syntax ?$(D)E(B "w" (standard-case-table))
+ (set-case-syntax ?$(D*D(B "w" (standard-case-table))))
(documentation . "Support for Turkish.
Differs from the Latin-5 environment in using the `turkish-postfix' input
-method and applying Turkish case rules for the characters i, I, ,C9(B, ,C)(B.")))
+method and applying Turkish case rules for the characters i, I, $(D)E(B, $(D*D(B.")))
;; Polish ISO 8859-2 environment.
;; Maintainer: Wlodek Bzyl <matwb@univ.gda.pl>
@@ -509,7 +509,7 @@ method and applying Turkish case rules for the characters i, I, ,C9(B, ,C)(B
(nonascii-translation . iso-8859-2)
(unibyte-display . iso-8859-2)
(tutorial . "TUTORIAL.pl")
- (sample-text . "P,As(Bjd,B<(B, ki,Bq(B-,B?(Be t,Bj(B chmurno,B6f(B w g,B31(Bb flaszy")
+ (sample-text . "P$(D+Q(Bjd$(D+u(B, ki$(D+M(B-$(D+w(Be t$(D+8(B chmurno$(D+\++(B w g$(D)H+((Bb flaszy")
(documentation . t))
'("European"))
@@ -575,6 +575,18 @@ method and applying Turkish case rules for the characters i, I, ,C9(B, ,C)(B
(documentation . "Support for Croatian with Latin-2 encoding."))
'("European"))
+(set-language-info-alist
+ "Brazilian Portuguese" '((tutorial . "TUTORIAL.pt_BR")
+ (charset iso-8859-1)
+ (coding-system iso-latin-1 iso-latin-9)
+ (coding-priority iso-latin-1)
+ (nonascii-translation . iso-8859-1)
+ (unibyte-display . iso-8859-1)
+ (input-method . "latin-1-prefix")
+ (sample-text . "Oi")
+ (documentation . "Support for Brazilian Portuguese."))
+ '("European"))
+
(define-coding-system 'mac-roman
"Mac Roman Encoding (MIME:MACINTOSH)."
diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el
index b4ec979d425..2f005c45708 100644
--- a/lisp/language/japanese.el
+++ b/lisp/language/japanese.el
@@ -97,6 +97,7 @@
(define-coding-system-alias 'shift_jis 'japanese-shift-jis)
(define-coding-system-alias 'sjis 'japanese-shift-jis)
+(define-coding-system-alias 'cp932 'japanese-shift-jis)
(define-coding-system 'japanese-cp932
"CP932 (Microsoft shift-jis)"
diff --git a/lisp/language/korean.el b/lisp/language/korean.el
index 9595ab4ed02..8624264185d 100644
--- a/lisp/language/korean.el
+++ b/lisp/language/korean.el
@@ -41,6 +41,7 @@
(define-coding-system-alias 'euc-kr 'korean-iso-8bit)
(define-coding-system-alias 'euc-korea 'korean-iso-8bit)
+(define-coding-system-alias 'cp949 'korean-iso-8bit)
(define-coding-system 'iso-2022-kr
"ISO 2022 based 7-bit encoding for Korean KSC5601 (MIME:ISO-2022-KR)."
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index 15d3eb0eb95..1e6a824d541 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -3864,24 +3864,6 @@ of `scheme-program-name'). Runs the hooks `inferior-scheme-mode-hook'
;;;***
-;;;### (autoloads (cp-make-coding-system) "code-pages" "international/code-pages.el"
-;;;;;; (16271 3438))
-;;; Generated autoloads from international/code-pages.el
-
-(autoload (quote cp-make-coding-system) "code-pages" "\
-Make coding system NAME for and 8-bit, extended-ASCII character set.
-V is a 128-long vector of characters to translate the upper half of
-the character set. DOC-STRING and MNEMONIC are used as the
-corresponding args of `make-coding-system'. If MNEMONIC isn't given,
-?* is used.
-Return an updated `non-iso-charset-alist'.
-
-\(fn NAME V &optional DOC-STRING MNEMONIC)" nil (quote macro))
-(autoload-coding-system 'pt154 '(require 'code-pages))
-(autoload-coding-system 'iso-8859-11 '(require 'code-pages))
-
-;;;***
-
;;;### (autoloads (codepage-setup cp-supported-codepages cp-offset-for-codepage
;;;;;; cp-language-for-codepage cp-charset-for-codepage cp-make-coding-systems-for-codepage)
;;;;;; "codepage" "international/codepage.el" (16215 28546))
diff --git a/lisp/locate.el b/lisp/locate.el
index eb8074c9f6c..3a18d77f089 100644
--- a/lisp/locate.el
+++ b/lisp/locate.el
@@ -24,42 +24,7 @@
;;; Commentary:
-;; Search a database of files and use dired commands on
-;; the result.
-;;
-
-;;;;; Building a database of files ;;;;;;;;;
-;;
-;; You can create a simple files database with a port of the Unix find command
-;; and one of the various Windows NT various scheduling utilities,
-;; for example the AT command from the NT Resource Kit, WinCron which is
-;; included with Microsoft FrontPage, or the shareware NTCron program.
-;;
-;; To set up a function which searches the files database, do something
-;; like this:
-;;
-;; (defvar locate-fcodes-file "c:/users/peter/fcodes")
-;; (defvar locate-make-command-line 'nt-locate-make-command-line)
-;;
-;; (defun nt-locate-make-command-line (arg)
-;; (list "grep" "-i" arg locate-fcodes-file))
-;;
-;;;;;;;; ADVICE For dired-make-relative: ;;;;;;;;;
-;;
-;; For certain dired commands to work right, you should also include the
-;; following in your _emacs/.emacs:
-;;
-;; (defadvice dired-make-relative (before set-no-error activate)
-;; "For locate mode and Windows, don't return errors"
-;; (if (and (eq major-mode 'locate-mode)
-;; (memq system-type (list 'windows-nt 'ms-dos)))
-;; (ad-set-arg 2 t)
-;; ))
-;;
-;; Otherwise, `dired-make-relative' will give error messages like
-;; "FILENAME: not in directory tree growing at /"
-
-;;; Commentary:
+;; Search a database of files and use dired commands on the result.
;;
;; Locate.el provides an interface to a program which searches a
;; database of file names. By default, this program is the GNU locate
@@ -109,6 +74,38 @@
;; regular expression; this is often useful to constrain a big search.
;;
+;;;;; Building a database of files ;;;;;;;;;
+;;
+;; You can create a simple files database with a port of the Unix find command
+;; and one of the various Windows NT various scheduling utilities,
+;; for example the AT command from the NT Resource Kit, WinCron which is
+;; included with Microsoft FrontPage, or the shareware NTCron program.
+;;
+;; To set up a function which searches the files database, do something
+;; like this:
+;;
+;; (defvar locate-fcodes-file "c:/users/peter/fcodes")
+;; (defvar locate-make-command-line 'nt-locate-make-command-line)
+;;
+;; (defun nt-locate-make-command-line (arg)
+;; (list "grep" "-i" arg locate-fcodes-file))
+;;
+;;;;;;;; ADVICE For dired-make-relative: ;;;;;;;;;
+;;
+;; For certain dired commands to work right, you should also include the
+;; following in your _emacs/.emacs:
+;;
+;; (defadvice dired-make-relative (before set-no-error activate)
+;; "For locate mode and Windows, don't return errors"
+;; (if (and (eq major-mode 'locate-mode)
+;; (memq system-type (list 'windows-nt 'ms-dos)))
+;; (ad-set-arg 2 t)
+;; ))
+;;
+;; Otherwise, `dired-make-relative' will give error messages like
+;; "FILENAME: not in directory tree growing at /"
+
+
;;; Code:
(eval-when-compile
@@ -154,13 +151,21 @@
:type 'face
:group 'locate)
+;;;###autoload
+(defcustom locate-ls-subdir-switches "-al"
+ "`ls' switches for inserting subdirectories in `*Locate*' buffers.
+This should contain the \"-l\" switch, but not the \"-F\" or \"-b\" switches."
+ :type 'string
+ :group 'locate
+ :version "21.4")
+
(defcustom locate-update-command "updatedb"
"The command used to update the locate database."
:type 'string
:group 'locate)
(defcustom locate-prompt-for-command nil
- "If non-nil, the default behavior of the locate command is to prompt for a command to run.
+ "If non-nil, the locate command prompts for a command to run.
Otherwise, that behavior is invoked via a prefix argument."
:group 'locate
:type 'boolean
@@ -223,24 +228,25 @@ With prefix arg, prompt for the locate command to run."
(save-window-excursion
(set-buffer (get-buffer-create locate-buffer-name))
(locate-mode)
- (erase-buffer)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
- (setq locate-current-filter filter)
+ (setq locate-current-filter filter)
- (if run-locate-command
- (shell-command search-string locate-buffer-name)
- (apply 'call-process locate-cmd nil t nil locate-cmd-args))
+ (if run-locate-command
+ (shell-command search-string locate-buffer-name)
+ (apply 'call-process locate-cmd nil t nil locate-cmd-args))
- (and filter
- (locate-filter-output filter))
+ (and filter
+ (locate-filter-output filter))
- (locate-do-setup search-string)
- )
+ (locate-do-setup search-string)
+ ))
(and (not (string-equal (buffer-name) locate-buffer-name))
(switch-to-buffer-other-window locate-buffer-name))
(run-hooks 'dired-mode-hook)
- (dired-next-line 2) ;move to first matching file.
+ (dired-next-line 3) ;move to first matching file.
(run-hooks 'locate-post-command-hook)
)
)
@@ -281,9 +287,10 @@ shown; this is often useful to constrain a big search."
(define-key locate-mode-map [menu-bar mark directories] 'undefined)
(define-key locate-mode-map [menu-bar mark symlinks] 'undefined)
- (define-key locate-mode-map [mouse-2] 'locate-mouse-view-file)
+ (define-key locate-mode-map [M-mouse-2] 'locate-mouse-view-file)
(define-key locate-mode-map "\C-c\C-t" 'locate-tags)
+ (define-key locate-mode-map "l" 'locate-do-redisplay)
(define-key locate-mode-map "U" 'dired-unmark-all-files)
(define-key locate-mode-map "V" 'locate-find-directory)
)
@@ -318,41 +325,74 @@ shown; this is often useful to constrain a big search."
(not (eq lineno 2))
(buffer-substring (elt pos 0) (elt pos 1)))))
+(defun locate-main-listing-line-p ()
+ "Return t if current line contains a file name listed by locate.
+This function returns nil if the current line either contains no
+file name or is inside a subdirectory."
+ (save-excursion
+ (forward-line 0)
+ (looking-at (concat "."
+ (make-string (1- locate-filename-indentation) ?\ )
+ "\\(/\\|[A-Za-z]:\\)"))))
+
(defun locate-mouse-view-file (event)
"In Locate mode, view a file, using the mouse."
(interactive "@e")
(save-excursion
(goto-char (posn-point (event-start event)))
- (view-file (locate-get-filename))))
+ (if (locate-main-listing-line-p)
+ (view-file (locate-get-filename))
+ (message "This command only works inside main listing."))))
;; Define a mode for locate
;; Default directory is set to "/" so that dired commands, which
;; expect to be in a tree, will work properly
(defun locate-mode ()
- "Major mode for the `*Locate*' buffer made by \\[locate]."
+ "Major mode for the `*Locate*' buffer made by \\[locate].
+\\<locate-mode-map>\
+In that buffer, you can use almost all the usual dired bindings.
+\\[locate-find-directory] visits the directory of the file on the current line.
+
+Operating on listed files works, but does not always
+automatically update the buffer as in ordinary Dired.
+This is true both for the main listing and for subdirectories.
+Reverting the buffer using \\[revert-buffer] deletes all subdirectories.
+Specific `locate-mode' commands, such as \\[locate-find-directory],
+do not work in subdirectories.
+
+\\{locate-mode-map}"
+ ;; Not to be called interactively.
(kill-all-local-variables)
- ;; Avoid clobbering this variables
+ ;; Avoid clobbering this variable
(make-local-variable 'dired-subdir-alist)
(use-local-map locate-mode-map)
(setq major-mode 'locate-mode
mode-name "Locate"
- default-directory "/")
+ default-directory "/"
+ buffer-read-only t
+ selective-display t)
(dired-alist-add-1 default-directory (point-min-marker))
+ (set (make-local-variable 'dired-directory) "/")
+ (set (make-local-variable 'dired-subdir-switches) locate-ls-subdir-switches)
+ (setq dired-switches-alist nil)
(make-local-variable 'dired-move-to-filename-regexp)
;; This should support both Unix and Windoze style names
(setq dired-move-to-filename-regexp
- (concat "."
+ (concat "^."
(make-string (1- locate-filename-indentation) ?\ )
- "\\(/\\|[A-Za-z]:\\)"))
+ "\\(/\\|[A-Za-z]:\\)\\|"
+ (default-value 'dired-move-to-filename-regexp)))
(make-local-variable 'dired-actual-switches)
(setq dired-actual-switches "")
(make-local-variable 'dired-permission-flags-regexp)
(setq dired-permission-flags-regexp
(concat "^.\\("
(make-string (1- locate-filename-indentation) ?\ )
- "\\)"))
+ "\\)\\|"
+ (default-value 'dired-permission-flags-regexp)))
(make-local-variable 'revert-buffer-function)
(setq revert-buffer-function 'locate-update)
+ (set (make-local-variable 'page-delimiter) "\n\n")
(run-hooks 'locate-mode-hook))
(defun locate-do-setup (search-string)
@@ -382,7 +422,10 @@ shown; this is often useful to constrain a big search."
(dired-insert-set-properties (elt pos 0) (elt pos 1)))))
(defun locate-insert-header (search-string)
- (let ((locate-format-string "Matches for %s")
+ ;; There needs to be a space before `Matches, because otherwise,
+ ;; `*!" would erase the `M'. We can not use two spaces, or the line
+ ;; would mistakenly fit `dired-subdir-regexp'.
+ (let ((locate-format-string " /:\n Matches for %s")
(locate-regexp-match
(concat " *Matches for \\(" (regexp-quote search-string) "\\)"))
(locate-format-args (list search-string))
@@ -420,6 +463,7 @@ shown; this is often useful to constrain a big search."
(save-excursion
(goto-char (point-min))
+ (forward-line 1)
(if (not (looking-at locate-regexp-match))
nil
(add-text-properties (match-beginning 1) (match-end 1)
@@ -435,9 +479,11 @@ shown; this is often useful to constrain a big search."
(defun locate-tags ()
"Visit a tags table in `*Locate*' mode."
(interactive)
- (let ((tags-table (locate-get-filename)))
- (and (y-or-n-p (format "Visit tags table %s? " tags-table))
- (visit-tags-table tags-table))))
+ (if (locate-main-listing-line-p)
+ (let ((tags-table (locate-get-filename)))
+ (and (y-or-n-p (format "Visit tags table %s? " tags-table))
+ (visit-tags-table tags-table)))
+ (message "This command only works inside main listing.")))
;; From Stephen Eglen <stephen@cns.ed.ac.uk>
(defun locate-update (ignore1 ignore2)
@@ -456,12 +502,14 @@ Database is updated using the shell command in `locate-update-command'."
(defun locate-find-directory ()
"Visit the directory of the file mentioned on this line."
(interactive)
- (let ((directory-name (locate-get-dirname)))
- (if (file-directory-p directory-name)
- (find-file directory-name)
- (if (file-symlink-p directory-name)
- (error "Directory is a symlink to a nonexistent target")
- (error "Directory no longer exists; run `updatedb' to update database")))))
+ (if (locate-main-listing-line-p)
+ (let ((directory-name (locate-get-dirname)))
+ (if (file-directory-p directory-name)
+ (find-file directory-name)
+ (if (file-symlink-p directory-name)
+ (error "Directory is a symlink to a nonexistent target")
+ (error "Directory no longer exists; run `updatedb' to update database"))))
+ (message "This command only works inside main listing.")))
(defun locate-find-directory-other-window ()
"Visit the directory of the file named on this line in other window."
@@ -514,6 +562,14 @@ Database is updated using the shell command in `locate-update-command'."
string))))))
(locate search-string)))
+(defun locate-do-redisplay (&optional arg test-for-subdir)
+ "Like `dired-do-redisplay', but adapted for `*Locate*' buffers."
+ (interactive "P\np")
+ (if (string= (dired-current-directory) "/")
+ (message "This command only works in subdirectories.")
+ (let ((dired-actual-switches locate-ls-subdir-switches))
+ (dired-do-redisplay arg test-for-subdir))))
+
(provide 'locate)
;;; arch-tag: 60c4d098-b5d5-4b3c-a3e0-51a2e9f43898
diff --git a/lisp/log-view.el b/lisp/log-view.el
index a6f736d16f7..51ca8907db8 100644
--- a/lisp/log-view.el
+++ b/lisp/log-view.el
@@ -191,8 +191,10 @@
"Get the diff for several revisions.
If the point is the same as the mark, get the diff for this revision.
Otherwise, get the diff between the revisions
- were the region starts and ends."
- (interactive "r")
+were the region starts and ends."
+ (interactive
+ (list (if mark-active (region-beginning) (point))
+ (if mark-active (region-end) (point))))
(let ((fr (log-view-current-tag beg))
(to (log-view-current-tag end)))
(when (string-equal fr to)
diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el
index 07ea44cef04..5d603d7be26 100644
--- a/lisp/mail/rfc2368.el
+++ b/lisp/mail/rfc2368.el
@@ -120,12 +120,13 @@ calling this function."
;; deal w/ multiple 'To' recipients
(if prequery
(progn
+ (setq prequery (rfc2368-unhexify-string prequery))
(if (assoc "To" headers-alist)
(let* ((our-cons-cell
(assoc "To" headers-alist))
(our-cdr
(cdr our-cons-cell)))
- (setcdr our-cons-cell (concat our-cdr ", " prequery)))
+ (setcdr our-cons-cell (concat prequery ", " our-cdr)))
(setq headers-alist
(cons (cons "To" prequery) headers-alist)))))
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 5ab38370e57..5fa4f34bbb8 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -227,7 +227,9 @@ and the value of the environment variable MAIL overrides it)."
;;;###autoload
(defcustom rmail-mail-new-frame nil
- "*Non-nil means Rmail makes a new frame for composing outgoing mail."
+ "*Non-nil means Rmail makes a new frame for composing outgoing mail.
+This is handy if you want to preserve the window configuration of
+the frame where you have the RMAIL buffer displayed."
:type 'boolean
:group 'rmail-reply)
@@ -1137,7 +1139,9 @@ Instead, these commands are available:
(make-local-variable 'kill-buffer-hook)
(add-hook 'kill-buffer-hook 'rmail-mode-kill-summary)
(make-local-variable 'file-precious-flag)
- (setq file-precious-flag t))
+ (setq file-precious-flag t)
+ (make-local-variable 'desktop-save-buffer)
+ (setq desktop-save-buffer t))
;; Handle M-x revert-buffer done in an rmail-mode buffer.
(defun rmail-revert (arg noconfirm)
@@ -1666,7 +1670,15 @@ It returns t if it got any new messages."
(defun rmail-decode-region (from to coding)
(if (or (not coding) (not (coding-system-p coding)))
(setq coding 'undecided))
- (decode-coding-region from to coding))
+ ;; Use -dos decoding, to remove ^M characters left from base64 or
+ ;; rogue qp-encoded text.
+ (decode-coding-region from to
+ (coding-system-change-eol-conversion coding 1))
+ ;; Don't reveal the fact we used -dos decoding, as users generally
+ ;; will not expect the RMAIL buffer to use DOS EOL format.
+ (setq buffer-file-coding-system
+ (setq last-coding-system-used
+ (coding-system-change-eol-conversion coding 0))))
;; the rmail-break-forwarded-messages feature is not implemented
(defun rmail-convert-to-babyl-format ()
@@ -1751,9 +1763,6 @@ It returns t if it got any new messages."
(error nil))
;; Change "base64" to "8bit", to reflect the
;; decoding we just did.
- (goto-char (1+ header-end))
- (while (search-forward "\r\n" (point-max) t)
- (replace-match "\n"))
(goto-char base64-header-field-end)
(delete-region (point) (search-backward ":"))
(insert ": 8bit"))))
@@ -1901,9 +1910,6 @@ It returns t if it got any new messages."
(point)))
t)
(error nil))
- (goto-char header-end)
- (while (search-forward "\r\n" (point-max) t)
- (replace-match "\n"))
;; Change "base64" to "8bit", to reflect the
;; decoding we just did.
(goto-char base64-header-field-end)
@@ -3167,7 +3173,7 @@ See also user-option `rmail-confirm-expunge'."
(compose-mail to subject others
noerase nil
yank-action sendactions)
- (if (and (display-multi-frame-p) rmail-mail-new-frame)
+ (if rmail-mail-new-frame
(prog1
(compose-mail to subject others
noerase 'switch-to-buffer-other-frame
@@ -3867,6 +3873,23 @@ encoded string (and the same mask) will decode the string."
(setq i (1+ i)))
(concat string-vector)))
+;;;; Desktop support
+
+;;;###autoload
+(defun rmail-restore-desktop-buffer (desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ "Restore an rmail buffer specified in a desktop file."
+ (condition-case error
+ (progn
+ (rmail-input desktop-buffer-file-name)
+ (if (eq major-mode 'rmail-mode)
+ (current-buffer)
+ rmail-buffer))
+ (file-locked
+ (kill-buffer (current-buffer))
+ nil)))
+
(provide 'rmail)
;;; arch-tag: cff0a950-57fe-4f73-a86e-91ff75afd06c
diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el
index 9ef7e575bed..9009b5a3c87 100644
--- a/lisp/mail/sendmail.el
+++ b/lisp/mail/sendmail.el
@@ -714,7 +714,12 @@ Prefix arg means don't delete this window."
(if (and (or (window-dedicated-p (frame-selected-window))
(cdr (assq 'mail-dedicated-frame (frame-parameters))))
(not (null (delq (selected-frame) (visible-frame-list)))))
- (delete-frame (selected-frame))
+ (progn
+ (if (display-multi-frame-p)
+ (delete-frame (selected-frame))
+ ;; The previous frame is where normally they have the
+ ;; RMAIL buffer displayed.
+ (other-frame -1)))
(let (rmail-flag summary-buffer)
(and (not arg)
(not (one-window-p))
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index 60831b259d8..84a61350145 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -483,7 +483,14 @@ This is relative to `smtpmail-queue-dir'.")
(setq cred-key (expand-file-name cred-key)))
(file-regular-p
(setq cred-cert (expand-file-name cred-cert))))
- (list "--key-file" cred-key "--cert-file" cred-cert))))
+ (list "--key-file" cred-key "--cert-file" cred-cert)))
+ (starttls-extra-arguments
+ (when (and (stringp cred-key) (stringp cred-cert)
+ (file-regular-p
+ (setq cred-key (expand-file-name cred-key)))
+ (file-regular-p
+ (setq cred-cert (expand-file-name cred-cert))))
+ (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))
(starttls-open-stream "SMTP" process-buffer host port)))))
(defun smtpmail-try-auth-methods (process supported-extensions host port)
diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el
index 55f611b53ad..db6990d625b 100644
--- a/lisp/mail/unrmail.el
+++ b/lisp/mail/unrmail.el
@@ -51,43 +51,71 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
(defun unrmail (file to-file)
"Convert Rmail file FILE to system inbox format file TO-FILE."
(interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ")
- (let ((message-count 1)
- ;; Prevent rmail from making, or switching to, a summary buffer.
- (rmail-display-summary nil)
- (rmail-delete-after-output nil)
- (temp-buffer (get-buffer-create " unrmail")))
- (rmail file)
+ (with-temp-buffer
+ ;; Read in the old Rmail file with no decoding.
+ (let ((coding-system-for-read 'raw-text))
+ (insert-file-contents file))
+ ;; But make it multibyte.
+ (set-buffer-multibyte t)
+
+ (if (not (looking-at "BABYL OPTIONS"))
+ (error "This file is not in Babyl format"))
+
+ ;; Decode the file contents just as Rmail did.
+ (let ((modifiedp (buffer-modified-p))
+ (coding-system rmail-file-coding-system)
+ from to)
+ (goto-char (point-min))
+ (search-forward "\n\^_" nil t) ; Skip BABYL header.
+ (setq from (point))
+ (goto-char (point-max))
+ (search-backward "\n\^_" from 'mv)
+ (setq to (point))
+ (unless (and coding-system
+ (coding-system-p coding-system))
+ (setq coding-system
+ ;; Emacs 21.1 and later writes RMAIL files in emacs-mule, but
+ ;; earlier versions did that with the current buffer's encoding.
+ ;; So we want to favor detection of emacs-mule (whose normal
+ ;; priority is quite low), but still allow detection of other
+ ;; encodings if emacs-mule won't fit. The call to
+ ;; detect-coding-with-priority below achieves that.
+ (car (detect-coding-with-priority
+ from to
+ '((coding-category-emacs-mule . emacs-mule))))))
+ (unless (memq coding-system
+ '(undecided undecided-unix))
+ (set-buffer-modified-p t) ; avoid locking when decoding
+ (let ((buffer-undo-list t))
+ (decode-coding-region from to coding-system))
+ (setq coding-system last-coding-system-used))
+
+ (setq buffer-file-coding-system nil)
+
+ ;; We currently don't use this value, but maybe we should.
+ (setq save-buffer-coding-system
+ (or coding-system 'undecided)))
+
;; Default the directory of TO-FILE based on where FILE is.
(setq to-file (expand-file-name to-file default-directory))
(condition-case ()
(delete-file to-file)
(file-error nil))
(message "Writing messages to %s..." to-file)
- (save-restriction
- (widen)
- (while (<= message-count rmail-total-messages)
- (let ((beg (rmail-msgbeg message-count))
- (end (rmail-msgbeg (1+ message-count)))
- (from-buffer (current-buffer))
- (coding (or rmail-file-coding-system 'raw-text))
+ (goto-char (point-min))
+
+ (let ((temp-buffer (get-buffer-create " unrmail"))
+ (from-buffer (current-buffer)))
+
+ ;; Process the messages one by one.
+ (while (search-forward "\^_\^l" nil t)
+ (let ((beg (point))
+ (end (save-excursion
+ (if (search-forward "\^_" nil t)
+ (1- (point)) (point-max))))
+ (coding 'raw-text)
label-line attrs keywords
- header-beginning mail-from)
- (save-excursion
- (goto-char (rmail-msgbeg message-count))
- (setq header-beginning (point))
- (search-forward "\n*** EOOH ***\n")
- (forward-line -1)
- (search-forward "\n\n")
- (save-restriction
- (narrow-to-region header-beginning (point))
- (setq mail-from
- (or (mail-fetch-field "Mail-From")
- (concat "From "
- (mail-strip-quoted-names (or (mail-fetch-field "from")
- (mail-fetch-field "really-from")
- (mail-fetch-field "sender")
- "unknown"))
- " " (current-time-string))))))
+ mail-from reformatted)
(with-current-buffer temp-buffer
(setq buffer-undo-list t)
(erase-buffer)
@@ -95,11 +123,15 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
(insert-buffer-substring from-buffer beg end)
(goto-char (point-min))
(forward-line 1)
+ ;; Record whether the header is reformatted.
+ (setq reformatted (= (following-char) ?1))
+
+ ;; Collect the label line, then get the attributes
+ ;; and the keywords from it.
(setq label-line
(buffer-substring (point)
- (progn (forward-line 1)
- (point))))
- (forward-line -1)
+ (save-excursion (forward-line 1)
+ (point))))
(search-forward ",,")
(unless (eolp)
(setq keywords
@@ -118,9 +150,61 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
(if (string-match ", resent," label-line) ?R ?-)
(if (string-match ", unseen," label-line) ?\ ?-)
(if (string-match ", stored," label-line) ?S ?-)))
- (unrmail-unprune)
+
+ ;; Delete the special Babyl lines at the start,
+ ;; and the ***EOOH*** line, and the reformatted header if any.
+ (goto-char (point-min))
+ (if reformatted
+ (progn
+ (forward-line 2)
+ ;; Delete Summary-Line headers.
+ (let ((case-fold-search t))
+ (while (looking-at "Summary-Line:")
+ (forward-line 1)))
+ (delete-region (point-min) (point))
+ ;; Delete the old reformatted header.
+ (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
+ (forward-line -1)
+ (let ((start (point)))
+ (search-forward "\n\n")
+ (delete-region start (point))))
+ ;; Not reformatted. Delete the special
+ ;; lines before the real header.
+ (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
+ (delete-region (point-min) (point)))
+
+ ;; Some operations on the message header itself.
(goto-char (point-min))
+ (save-restriction
+ (narrow-to-region
+ (point-min)
+ (save-excursion (search-forward "\n\n" nil 'move) (point)))
+
+ ;; Fetch or construct what we should use in the `From ' line.
+ (setq mail-from
+ (or (mail-fetch-field "Mail-From")
+ (concat "From "
+ (mail-strip-quoted-names (or (mail-fetch-field "from")
+ (mail-fetch-field "really-from")
+ (mail-fetch-field "sender")
+ "unknown"))
+ " " (current-time-string))))
+
+ ;; If the message specifies a coding system, use it.
+ (let ((maybe-coding (mail-fetch-field "X-Coding-System")))
+ (if maybe-coding
+ (setq coding (intern maybe-coding))))
+
+ ;; Delete the Mail-From: header field if any.
+ (when (re-search-forward "^Mail-from:" nil t)
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (forward-line 1) (point)))))
+
+ (goto-char (point-min))
+ ;; Insert the `From ' line.
(insert mail-from "\n")
+ ;; Record the keywords and attributes in our special way.
(insert "X-BABYL-V6-ATTRIBUTES: " (apply 'string attrs) "\n")
(when keywords
(insert "X-BABYL-V6-KEYWORDS: " keywords "\n"))
@@ -132,43 +216,12 @@ For example, invoke `emacs -batch -f batch-unrmail RMAIL'."
(while (search-forward "\nFrom " nil t)
(forward-char -5)
(insert ?>)))
+ ;; Write it to the output file.
(write-region (point-min) (point-max) to-file t
- 'nomsg)))
- (setq message-count (1+ message-count))))
+ 'nomsg))))
+ (kill-buffer temp-buffer))
(message "Writing messages to %s...done" to-file)))
-(defun unrmail-unprune ()
- (let* ((pruned
- (save-excursion
- (goto-char (point-min))
- (forward-line 1)
- (= (following-char) ?1))))
- (if pruned
- (progn
- (goto-char (point-min))
- (forward-line 2)
- ;; Delete Summary-Line headers.
- (let ((case-fold-search t))
- (while (looking-at "Summary-Line:")
- (forward-line 1)))
- (delete-region (point-min) (point))
- ;; Delete the old reformatted header.
- (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
- (forward-line -1)
- (let ((start (point)))
- (search-forward "\n\n")
- (delete-region start (point))))
- ;; Delete everything up to the real header.
- (goto-char (point-min))
- (re-search-forward "^[*][*][*] EOOH [*][*][*]\n")
- (delete-region (point-min) (point)))
- (goto-char (point-min))
- (when (re-search-forward "^Mail-from:")
- (beginning-of-line)
- (delete-region (point)
- (progn (forward-line 1) (point))))))
-
-
(provide 'unrmail)
;;; unrmail.el ends here
diff --git a/lisp/makefile.nt b/lisp/makefile.nt
deleted file mode 100644
index 069ef96ac98..00000000000
--- a/lisp/makefile.nt
+++ /dev/null
@@ -1,284 +0,0 @@
-# Hacked up Nmake makefile for GNU Emacs
-# Geoff Voelker (voelker@cs.washington.edu)
-# Copyright (c) 1994 Free Software Foundation, Inc.
-#
-# 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 2, 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., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-#
-
-!include ..\nt\makefile.def
-
-all:
-
-#lisp=$(MAKEDIR:\=/)
-lisp=.
-
-# You can specify a different executable on the make command line,
-# e.g. "make EMACS=../src/emacs ...".
-
-EMACS = ..\bin\emacs.exe
-
-# Command line flags for Emacs. This must include --multibyte,
-# otherwise some files will not compile.
-
-EMACSOPT = -batch --no-init-file --no-site-file --multibyte
-
-lisptagsfiles1 = $(lisp)/*.el
-lisptagsfiles2 = $(lisp)/*/*.el
-ETAGS = ..\lib-src\$(BLD)\etags
-
-# Files which should not be compiled.
-# - emacs-lisp/cl-specs.el: only contains `def-edebug-spec's so there's
-# no point compiling it, although it doesn't hurt.
-
-DONTCOMPILE = \
- $(lisp)/cus-load.el \
- $(lisp)/cus-start.el \
- $(lisp)/emacs-lisp/cl-specs.el \
- $(lisp)/eshell/esh-maint.el \
- $(lisp)/eshell/esh-groups.el \
- $(lisp)/finder-inf.el \
- $(lisp)/forms-d2.el \
- $(lisp)/forms-pass.el \
- $(lisp)/generic-x.el \
- $(lisp)/international/latin-1.el \
- $(lisp)/international/latin-2.el \
- $(lisp)/international/latin-3.el \
- $(lisp)/international/latin-4.el \
- $(lisp)/international/latin-5.el \
- $(lisp)/international/latin-8.el \
- $(lisp)/international/latin-9.el \
- $(lisp)/international/mule-conf.el \
- $(lisp)/loaddefs.el \
- $(lisp)/loadup.el \
- $(lisp)/mail/blessmail.el \
- $(lisp)/patcomp.el \
- $(lisp)/paths.el \
- $(lisp)/play/bruce.el \
- $(lisp)/subdirs.el \
- $(lisp)/term/internal.el \
- $(lisp)/term/AT386.el \
- $(lisp)/term/apollo.el \
- $(lisp)/term/bobcat.el \
- $(lisp)/term/iris-ansi.el \
- $(lisp)/term/keyswap.el \
- $(lisp)/term/linux.el \
- $(lisp)/term/lk201.el \
- $(lisp)/term/news.el \
- $(lisp)/term/vt102.el \
- $(lisp)/term/vt125.el \
- $(lisp)/term/vt200.el \
- $(lisp)/term/vt201.el \
- $(lisp)/term/vt220.el \
- $(lisp)/term/vt240.el \
- $(lisp)/term/vt300.el \
- $(lisp)/term/vt320.el \
- $(lisp)/term/vt400.el \
- $(lisp)/term/vt420.el \
- $(lisp)/term/wyse50.el \
- $(lisp)/term/xterm.el \
- $(lisp)/version.el
-
-# Files to compile before others during a bootstrap. This is done
-# to speed up the bootstrap process.
-
-COMPILE_FIRST = \
- $(lisp)/emacs-lisp/byte-opt.el \
- $(lisp)/emacs-lisp/bytecomp.el \
- $(lisp)/subr.el
-
-# The actual Emacs command run in the targets below.
-
-emacs = $(EMACS) $(EMACSOPT)
-
-# Common command to find subdirectories
-
-# setwins=subdirs=`find $$wd -type d -print`; \
-# for file in $$subdirs; do \
-# case $$file in */Old | */RCS | */CVS | */CVS/* | */=* ) ;; \
-# *) wins="$$wins $$file" ;; \
-# esac; \
-# done
-
-# Have to define the list of subdirs manually
-WINS=\
- calendar \
- emacs-lisp \
- emulation \
- eshell \
- gnus \
- international \
- language \
- mail \
- mh-e \
- net \
- play \
- progmodes \
- term \
- textmodes
-
-doit:
-
-cus-load.el:
- touch $@
-custom-deps: cus-load.el doit
- @echo Directories: $(WINS)
- $(emacs) -l cus-dep --eval "(setq find-file-hooks nil)" -f custom-make-dependencies $(lisp) $(WINS)
-
-finder-inf.el:
- echo (provide 'finder-inf)>> $@
-
-finder-data: finder-inf.el doit
- @echo Directories: $(WINS)
- $(emacs) -l finder -f finder-compile-keywords-make-dist $(lisp) $(WINS)
-
-loaddefs.el:
- echo ;;; loaddefs.el --- automatically extracted autoloads> $@
- echo ;;; Code:>> $@
- echo >> $@
- echo ;;; Local Variables:>> $@
- echo ;;; version-control: never>> $@
- echo ;;; no-byte-compile: t>> $@
- echo ;;; no-update-autoloads: t>> $@
- echo ;;; End:>> $@
- echo ;;; loaddefs.el ends here>> $@
-
-autoloads: loaddefs.el doit
- @echo Directories: $(WINS)
- $(emacs) -l autoload --eval "(setq find-file-hooks nil generated-autoload-file \"$(lisp)/loaddefs.el\")" -f batch-update-autoloads $(lisp) $(WINS)
-
-subdirs.el:
- $(MAKE) $(MFLAGS) -f makefile.nt update-subdirs
-update-subdirs: doit
- @set QWINS=
- @for %d in ($(WINS)) do if not (%d)==(term) set QWINS=%QWINS% "%d"
- echo ;; In load-path, after this directory should come> subdirs.el
- echo ;; certain of its subdirectories. Here we specify them.>> subdirs.el
- echo (normal-top-level-add-to-load-path '(%QWINS%))>> subdirs.el
-
-updates: update-subdirs autoloads finder-data custom-deps
-
-TAGS: $(lisptagsfiles1) $(lisptagsfiles2)
- $(ETAGS) $(lisptagsfiles1) $(lisptagsfiles2)
-
-TAGS-LISP: $(lispsource)$(lisptagsfiles1) $(lispsource)$(lisptagsfiles2)
- $(ETAGS) -o TAGS-LISP $(lispsource)$(lisptagsfiles1) $(lispsource)$(lisptagsfiles2)
-
-.SUFFIXES: .elc .el
-
-.el.elc:
- -$(emacs) -f batch-byte-compile $<
-
-$(DONTCOMPILE:.el=.elc):
- -$(DEL) $@
-
-# Compile all Lisp files, except those from DONTCOMPILE. This
-# compiles files unconditionally. All .elc files are made writable
-# before compilation in case we checked out read-only (CVS option -r).
-# Files MUST be compiled one by one. If we compile several files in a
-# row we can't make sure that the compilation environment is clean.
-# We also set the load-path of the Emacs used for compilation to the
-# current directory and its subdirectories, to make sure require's and
-# load's in the files being compiled find the right files.
-
-compile-files: subdirs.el doit
-# -for %f in ($(lisp) $(WINS)) do for %g in (%f\*.elc) do @attrib -r %g
- for %f in ($(COMPILE_FIRST)) do $(emacs) -f batch-byte-compile %f
- for %f in ($(lisp) $(WINS)) do for %g in (%f/*.el) do $(emacs) -f batch-byte-compile %f/%g
-
-# Backup compiled Lisp files in elc.tar.gz. If that file already
-# exists, make a backup of it.
-
-backup-compiled-files:
- -mv $(lisp)/elc.tar.gz $(lisp)/elc.tar.gz~
- -tar czf $(lisp)/elc.tar.gz $(lisp)/*.elc $(lisp)/*/*.elc
-
-# Compile Lisp files, but save old compiled files first.
-
-compile: backup-compiled-files compile-files
-
-# Recompile all Lisp files which are newer than their .elc files.
-# Note that this doesn't create .elc files. It only recompiles if an
-# .elc is present.
-
-recompile: doit
- $(emacs) -f batch-byte-recompile-directory .
-
-# Prepare a bootstrap in the lisp subdirectory. Build loaddefs.el,
-# because it's not sure it's up-to-date, and if it's not, that might
-# lead to errors during the bootstrap because something fails to
-# autoload as expected. Remove compiled Lisp files so that
-# bootstrap-emacs will be built from sources only.
-
-bootstrap-clean:
- if exist $(EMACS) $(MAKE) $(MFLAGS) -f makefile.nt autoloads
- -for %f in ($(lisp) $(WINS)) do for %g in (%f\*.elc) do @$(DEL) %g
-
-# Generate/update files for the bootstrap process.
-
-bootstrap: autoloads compile-files custom-deps
-
-#
-# Assuming INSTALL_DIR is defined, copy the elisp files to it
-# Windows 95 makes this harder than it should be.
-#
-install:
- - mkdir $(INSTALL_DIR)\lisp
- - $(DEL) .\same-dir.tst
- - $(DEL) $(INSTALL_DIR)\lisp\same-dir.tst
- echo SameDirTest > $(INSTALL_DIR)\lisp\same-dir.tst
-!ifdef COPY_LISP_SOURCE
- if not exist .\same-dir.tst $(CP_DIR) . $(INSTALL_DIR)\lisp
-!else
- if not exist .\same-dir.tst $(CP_DIR) *.elc $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) cus-load.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) cus-start.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) emacs-lisp\cl-specs.el $(INSTALL_DIR)\lisp\emacs-lisp
- if not exist .\same-dir.tst $(CP) eshell\esh-maint.el $(INSTALL_DIR)\lisp\eshell
- if not exist .\same-dir.tst $(CP) eshell\esh-groups.el $(INSTALL_DIR)\lisp\eshell
- if not exist .\same-dir.tst $(CP) finder-inf.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) forms*.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) generic-x.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) patcomp.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) subdirs.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) version.el $(INSTALL_DIR)\lisp
- if not exist .\same-dir.tst $(CP) mail\blessmail.el $(INSTALL_DIR)\lisp\mail
- if not exist .\same-dir.tst $(CP) play\bruce.el $(INSTALL_DIR)\lisp\play
- if not exist .\same-dir.tst $(CP) international\latin-*.el $(INSTALL_DIR)\lisp\international
- if not exist .\same-dir.tst $(CP) international\mule-conf.el $(INSTALL_DIR)\lisp\international
- - $(DEL) $(INSTALL_DIR)\lisp\same-dir.tst
-!endif
-
-#
-# Maintenance
-#
-clean:
- - $(DEL) *~ term\*~
- - $(DEL) *.orig *.rej *.crlf
- - $(DEL) emacs-lisp\*.orig emacs-lisp\*.rej emacs-lisp\*.crlf
- - $(DEL) emulation\*.orig emulation\*.rej emulation\*.crlf
- - $(DEL) gnus\*.orig gnus\*.rej gnus\*.crlf
- - $(DEL) international\*.orig international\*.rej international\*.crlf
- - $(DEL) language\*.orig language\*.rej language\*.crlf
- - $(DEL) mail\*.orig mail\*.rej mail\*.crlf
- - $(DEL) play\*.orig play\*.rej play\*.crlf
- - $(DEL) progmodes\*.orig progmodes\*.rej progmodes\*.crlf
- - $(DEL) term\*.orig term\*.rej term\*.crlf
- - $(DEL) textmodes\*.orig textmodes\*.rej textmodes\*.crlf
- - $(DEL_TREE) deleted
-
-# arch-tag: 01ddeb44-fb4c-4366-8478-4a6c21a68fb3
diff --git a/lisp/makefile.w32-in b/lisp/makefile.w32-in
index 6791cb0aea4..826cf89bfec 100644
--- a/lisp/makefile.w32-in
+++ b/lisp/makefile.w32-in
@@ -1,5 +1,5 @@
-# Makefile for GNU Emacs on the Microsoft W32 API.
-# Copyright (c) 2000-2001 Free Software Foundation, Inc.
+# -*- Makefile -*- for GNU Emacs on the Microsoft W32 API.
+# Copyright (c) 2000,2001,2004 Free Software Foundation, Inc.
#
# This file is part of GNU Emacs.
#
@@ -42,9 +42,6 @@ EMACSOPT = -batch --no-init-file --no-site-file --multibyte
# Set EMACSLOADPATH correctly (already defined in environment).
EMACSLOADPATH=$(lisp)
-# Use C locale
-LC_ALL = C
-
lisptagsfiles1 = $(lisp)/*.el
lisptagsfiles2 = $(lisp)/*/*.el
ETAGS = "../lib-src/$(BLD)/etags"
@@ -65,7 +62,13 @@ DONTCOMPILE = \
$(lisp)/forms-d2.el \
$(lisp)/forms-pass.el \
$(lisp)/generic-x.el \
- $(lisp)/international/latin1-disp.el \
+ $(lisp)/international/latin-1.el \
+ $(lisp)/international/latin-2.el \
+ $(lisp)/international/latin-3.el \
+ $(lisp)/international/latin-4.el \
+ $(lisp)/international/latin-5.el \
+ $(lisp)/international/latin-8.el \
+ $(lisp)/international/latin-9.el \
$(lisp)/international/mule-conf.el \
$(lisp)/language/czech.el \
$(lisp)/language/devanagari.el \
@@ -84,10 +87,6 @@ DONTCOMPILE = \
$(lisp)/language/thai.el \
$(lisp)/language/utf-8-lang.el \
$(lisp)/language/georgian.el \
- $(lisp)/language/vietnamese.el \
- $(lisp)/language/cyrillic.el \
- $(lisp)/language/chinese.el \
- $(lisp)/language/indian.el \
$(lisp)/loaddefs.el \
$(lisp)/ldefs-boot.el \
$(lisp)/loadup.el \
@@ -162,7 +161,8 @@ WINS=\
progmodes \
term \
textmodes \
- toolbar
+ toolbar \
+ url
doit:
@@ -237,7 +237,7 @@ update-subdirs-CMD: doit
echo ;; In load-path, after this directory should come>> subdirs.el
echo ;; certain of its subdirectories. Here we specify them.>> subdirs.el
echo (normal-top-level-add-to-load-path $(SQUOTE)(>> subdirs.el
- @for %d in ($(WINS)) do if not (%d)==(term) echo "%d">> subdirs.el
+ @for %%d in ($(WINS)) do if not (%%d)==(term) echo "%%d">> subdirs.el
echo ))>> subdirs.el
update-subdirs-SH: doit
@@ -282,11 +282,11 @@ $(DONTCOMPILE:.el=.elc):
compile: subdirs.el compile-$(SHELLTYPE) doit
compile-CMD:
-# -for %f in ($(lisp) $(WINS)) do for %g in (%f\*.elc) do @attrib -r %g
- for %f in ($(COMPILE_FIRST)) do \
- $(emacs) -l loaddefs -f batch-byte-compile-if-not-done %f
- for %f in (. $(WINS)) do for %g in (%f/*.el) do \
- $(emacs) -l loaddefs -f batch-byte-compile-if-not-done %f/%g
+# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
+ for %%f in ($(COMPILE_FIRST)) do \
+ $(emacs) -l loaddefs -f batch-byte-compile-if-not-done %%f
+ for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do \
+ $(emacs) -l loaddefs -f batch-byte-compile-if-not-done %%f/%%g
compile-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
@@ -309,9 +309,9 @@ compile-SH:
compile-always: subdirs.el compile-always-$(SHELLTYPE) doit
compile-always-CMD:
-# -for %f in ($(lisp) $(WINS)) do for %g in (%f\*.elc) do @attrib -r %g
- for %f in ($(COMPILE_FIRST)) do $(emacs) -f batch-byte-compile %f
- for %f in (. $(WINS)) do for %g in (%f/*.el) do $(emacs) -f batch-byte-compile %f/%g
+# -for %%f in ($(lisp) $(WINS)) do for %%g in (%%f\*.elc) do @attrib -r %%g
+ for %%f in ($(COMPILE_FIRST)) do $(emacs) -f batch-byte-compile %%f
+ for %%f in (. $(WINS)) do for %%g in (%%f/*.el) do $(emacs) -f batch-byte-compile %%f/%%g
compile-always-SH:
# for elc in $(lisp)/*.elc $(lisp)/*/*.elc; do attrib -r $$elc; done
@@ -329,7 +329,7 @@ compile-always-SH:
compile-calc: compile-calc-$(SHELLTYPE)
compile-calc-CMD:
- for %f in ($(lisp)/calc/*.el) do $(emacs) -f batch-byte-compile %f
+ for %%f in ($(lisp)/calc/*.el) do $(emacs) -f batch-byte-compile %%f
compile-calc-SH:
for el in $(lisp)/calc/*.el; do \
@@ -374,7 +374,7 @@ bootstrap-clean: bootstrap-clean-$(SHELLTYPE) loaddefs.el
bootstrap-clean-CMD:
# if exist $(EMACS) $(MAKE) $(MFLAGS) autoloads
if not exist $(lisp)\loaddefs.el cp $(lisp)/ldefs-boot.el $(lisp)/loaddefs.el
- -for %f in (. $(WINS)) do for %g in (%f\*.elc) do @$(DEL) %g
+ -for %%f in (. $(WINS)) do for %%g in (%%f\*.elc) do @$(DEL) %%g
bootstrap-clean-SH:
# if test -f $(EMACS); then $(MAKE) $(MFLAGS) autoloads; fi
@@ -420,5 +420,3 @@ install:
#
clean:
- $(DEL) *~
-
-# arch-tag: bd03b562-c58d-4403-99db-c7bccd8c49a0
diff --git a/lisp/man.el b/lisp/man.el
index 7222c1bad15..5a07045dda9 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -732,11 +732,14 @@ all sections related to a subject, put something appropriate into the
(setenv "GROFF_NO_SGR" "1")
(if (fboundp 'start-process)
(set-process-sentinel
- (start-process manual-program buffer "sh" "-c"
+ (start-process manual-program buffer
+ (if (eq system-type 'cygwin) shell-file-name "sh")
+ shell-command-switch
(format (Man-build-man-command) man-args))
'Man-bgproc-sentinel)
(let ((exit-status
- (call-process shell-file-name nil (list buffer nil) nil "-c"
+ (call-process shell-file-name nil (list buffer nil) nil
+ shell-command-switch
(format (Man-build-man-command) man-args)))
(msg ""))
(or (and (numberp exit-status)
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 7db5f96e6d7..17deeff4619 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -893,7 +893,7 @@ PROPS are additional properties."
'("--"))
(define-key menu-bar-options-menu [cua-mode]
(menu-bar-make-mm-toggle cua-mode
- "CUA-style cut and paste"
+ "C-x/C-c/C-v cut and paste (CUA)"
"Use C-z/C-x/C-c/C-v keys for undo/cut/copy/paste"))
(define-key menu-bar-options-menu [case-fold-search]
@@ -1557,7 +1557,8 @@ Buffers menu is regenerated."
(setq buffers-menu (cons 'keymap (cons "Select Buffer" buffers-menu)))
(define-key (current-global-map) [menu-bar buffer]
- (cons "Buffers" buffers-menu)))))
+ ;; Call copy-sequence so the string is not pure.
+ (cons (copy-sequence "Buffers") buffers-menu)))))
(add-hook 'menu-bar-update-hook 'menu-bar-update-buffers)
diff --git a/lisp/mh-e/ChangeLog b/lisp/mh-e/ChangeLog
index 92c2600560f..6eb2c1bc2ec 100644
--- a/lisp/mh-e/ChangeLog
+++ b/lisp/mh-e/ChangeLog
@@ -1,3 +1,6 @@
+2004-04-26 Lars Hansen <larsh@math.ku.dk>
+ * mh-e.el (mh-folder-mode): Bind desktop-save-buffer to t.
+
2003-04-24 Bill Wohler <wohler@newt.com>
* Released MH-E version 7.3.
@@ -47,6 +50,10 @@
runs checkdoc and lm-verify which is useful before releasing the
software. It can and should be expanded to do real unit tests.
+2004-04-22 Lars Hansen <larsh@math.ku.dk>
+
+ * mh-e.el (mh-restore-desktop-buffer): Delete with-no-warnings.
+
2003-04-22 Mark D Baushke <mdb@gnu.org>
* mh-alias.el: Update Copyright.
@@ -71,6 +78,11 @@
Emacs.
(mh-exec-cmd-error): Add a comment, so that we change it later on.
+2004-04-21 Lars Hansen <larsh@math.ku.dk>
+
+ * mh-e.el (mh-restore-desktop-buffer): Move from
+ desktop.el. Add Parameters.
+
2003-04-18 Steve Youngs <youngs@xemacs.org>
* mh-xemacs-icons.el (mh-xemacs-icons): Provide 'mh-xemacs-icons'
diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el
index c4b027f382f..344a67f5725 100644
--- a/lisp/mh-e/mh-e.el
+++ b/lisp/mh-e/mh-e.el
@@ -1548,6 +1548,8 @@ When a folder is visited, the hook `mh-folder-mode-hook' is run.
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(mh-folder-font-lock-keywords t))
+ (make-local-variable 'desktop-save-buffer)
+ (setq desktop-save-buffer t)
(mh-make-local-vars
'mh-current-folder (buffer-name) ; Name of folder, a string
'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs
@@ -2441,6 +2443,17 @@ well.")
"^There is no other window$"))
(add-to-list 'debug-ignored-errors mess))
+;;;; Desktop support
+
+;;;###autoload
+(defun mh-restore-desktop-buffer (desktop-buffer-file-name
+ desktop-buffer-name
+ desktop-buffer-misc)
+ "Restore an mh folder buffer specified in a desktop file."
+ (mh-find-path)
+ (mh-visit-folder desktop-buffer-name)
+ (current-buffer))
+
(provide 'mh-e)
;;; Local Variables:
diff --git a/lisp/minibuf-eldef.el b/lisp/minibuf-eldef.el
index 10bf38f945f..908b77aab33 100644
--- a/lisp/minibuf-eldef.el
+++ b/lisp/minibuf-eldef.el
@@ -1,6 +1,6 @@
;;; minibuf-eldef.el --- Only show defaults in prompts when applicable
;;
-;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc.
;;
;; Author: Miles Bader <miles@gnu.org>
;; Keywords: convenience
@@ -36,7 +36,7 @@
;;; Code:
(defvar minibuffer-default-in-prompt-regexps
- '(("\\( (default\\>.*)\\):? \\'" . 1))
+ '(("\\( (default\\>.*)\\):? \\'" . 1) ("\\( \\[.*\\]\\):? *\\'" . 1))
"*A list of regexps matching the parts of minibuffer prompts showing defaults.
When `minibuffer-electric-default-mode' is active, these regexps are
used to identify the portions of prompts to elide.
@@ -157,5 +157,5 @@ Returns non-nil if the new state is enabled."
(provide 'minibuf-eldef)
-;;; arch-tag: 7e421fae-c275-4729-b0da-7836af377d3d
+;; arch-tag: 7e421fae-c275-4729-b0da-7836af377d3d
;;; minibuf-eldef.el ends here
diff --git a/lisp/mouse.el b/lisp/mouse.el
index faa10e842d3..7f9d080478a 100644
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -42,6 +42,12 @@
"*If non-nil, mouse yank commands yank at point instead of at click."
:type 'boolean
:group 'mouse)
+
+(defcustom mouse-drag-copy-region t
+ "*If non-nil, mouse drag copies region to kill-ring."
+ :type 'boolean
+ :group 'mouse)
+
;; Provide a mode-specific menu on a mouse button.
@@ -612,11 +618,14 @@ This should be bound to a mouse drag event."
;; Don't set this-command to kill-region, so that a following
;; C-w will not double the text in the kill ring.
;; Ignore last-command so we don't append to a preceding kill.
- (let (this-command last-command deactivate-mark)
- (copy-region-as-kill (mark) (point)))
+ (when mouse-drag-copy-region
+ (let (this-command last-command deactivate-mark)
+ (copy-region-as-kill (mark) (point))))
(mouse-set-region-1)))
(defun mouse-set-region-1 ()
+ ;; Set transient-mark-mode for a little while.
+ (setq transient-mark-mode (or transient-mark-mode 'only))
(setq mouse-last-region-beg (region-beginning))
(setq mouse-last-region-end (region-end))
(setq mouse-last-region-tick (buffer-modified-tick)))
@@ -827,8 +836,9 @@ If the click is in the echo area, display the `*Messages*' buffer."
(push-mark region-commencement t t)
(goto-char region-termination)
;; Don't let copy-region-as-kill set deactivate-mark.
- (let (deactivate-mark)
- (copy-region-as-kill (point) (mark t)))
+ (when mouse-drag-copy-region
+ (let (deactivate-mark)
+ (copy-region-as-kill (point) (mark t))))
(let ((buffer (current-buffer)))
(mouse-show-mark)
;; mouse-show-mark can call read-event,
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index 8e1068a5bed..09448e87329 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -4116,6 +4116,9 @@ directory, so that Emacs will know its current contents."
(format "Getting %s" fn1))
tmp1))))
+(defun ange-ftp-file-remote-p (file)
+ (when (ange-ftp-ftp-name file) t))
+
(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
(let ((tryfiles (if nosuffix
@@ -4257,9 +4260,6 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(let ((fn (get operation 'ange-ftp)))
(if fn (save-match-data (apply fn args))
(ange-ftp-run-real-handler operation args))))
-;;;###autoload
-;;; These file names are remote file names.
-(put 'ange-ftp-hook-function 'file-remote-p t)
;; The following code is commented out because Tramp now deals with
;; Ange-FTP filenames, too.
@@ -4327,6 +4327,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
(put 'file-name-completion 'ange-ftp 'ange-ftp-file-name-completion)
(put 'insert-directory 'ange-ftp 'ange-ftp-insert-directory)
(put 'file-local-copy 'ange-ftp 'ange-ftp-file-local-copy)
+(put 'file-remote-p 'ange-ftp 'ange-ftp-file-remote-p)
(put 'unhandled-file-name-directory 'ange-ftp
'ange-ftp-unhandled-file-name-directory)
(put 'file-name-sans-versions 'ange-ftp 'ange-ftp-file-name-sans-versions)
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index a70e08028d2..1dbd97f0073 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -577,13 +577,22 @@ down (this *won't* always work)."
(defun browse-url-interactive-arg (prompt)
"Read a URL from the minibuffer, prompting with PROMPT.
-Default to the URL at or before point. If invoked with a mouse button,
-set point to the position clicked first. Return a list for use in
-`interactive' containing the URL and `browse-url-new-window-flag' or its
-negation if a prefix argument was given."
+If `transient-mark-mode' is non-nil and the mark is active,
+it defaults to the current region, else to the URL at or before
+point. If invoked with a mouse button, it moves point to the
+position clicked before acting.
+
+This function returns a list (URL NEW-WINDOW-FLAG)
+for use in `interactive'."
(let ((event (elt (this-command-keys) 0)))
(and (listp event) (mouse-set-point event)))
- (list (read-string prompt (browse-url-url-at-point))
+ (list (read-string prompt (or (and transient-mark-mode mark-active
+ ;; rfc2396 Appendix E.
+ (replace-regexp-in-string
+ "[\t\r\f\n ]+" ""
+ (buffer-substring-no-properties
+ (region-beginning) (region-end))))
+ (browse-url-url-at-point)))
(not (eq (null browse-url-new-window-flag)
(null current-prefix-arg)))))
@@ -847,7 +856,7 @@ used instead of `browse-url-new-window-flag'."
(or (eq (process-exit-status process) 0)
(let* ((process-environment (browse-url-process-environment)))
;; Netscape not running - start it
- (message "Starting Netscape...")
+ (message "Starting %s..." browse-url-netscape-program)
(apply 'start-process (concat "netscape" url) nil
browse-url-netscape-program
(append browse-url-netscape-startup-arguments (list url))))))
@@ -918,7 +927,7 @@ used instead of `browse-url-new-window-flag'."
(or (eq (process-exit-status process) 0)
(let* ((process-environment (browse-url-process-environment)))
;; Mozilla is not running - start it
- (message "Starting Mozilla...")
+ (message "Starting %s..." browse-url-mozilla-program)
(apply 'start-process (concat "mozilla " url) nil
browse-url-mozilla-program
(append browse-url-mozilla-startup-arguments (list url))))))
@@ -968,7 +977,7 @@ used instead of `browse-url-new-window-flag'."
(or (eq (process-exit-status process) 0)
(let* ((process-environment (browse-url-process-environment)))
;; Galeon is not running - start it
- (message "Starting Galeon...")
+ (message "Starting %s..." browse-url-galeon-program)
(apply 'start-process (concat "galeon " url) nil
browse-url-galeon-program
(append browse-url-galeon-startup-arguments (list url))))))
@@ -1017,7 +1026,7 @@ used instead of `browse-url-new-window-flag'."
(or (eq (process-exit-status process) 0)
(let* ((process-environment (browse-url-process-environment)))
;; Epiphany is not running - start it
- (message "Starting Epiphany...")
+ (message "Starting %s..." browse-url-epiphany-program)
(apply 'start-process (concat "epiphany " url) nil
browse-url-epiphany-program
(append browse-url-epiphany-startup-arguments (list url))))))
@@ -1098,10 +1107,10 @@ used instead of `browse-url-new-window-flag'."
(message "Signalling Mosaic...done")
)
;; Mosaic not running - start it
- (message "Starting Mosaic...")
+ (message "Starting %s..." browse-url-mosaic-program)
(apply 'start-process "xmosaic" nil browse-url-mosaic-program
(append browse-url-mosaic-arguments (list url)))
- (message "Starting Mosaic...done"))))
+ (message "Starting %s...done" browse-url-mosaic-program))))
;; --- Grail ---
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index 55af47e6a87..f093fb1cbcc 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -554,7 +554,7 @@ an alist of attribute/value pairs."
(setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
(eval `(call-process ldap-ldapsearch-prog
nil
- buf
+ `(,buf nil)
nil
,@arglist
,@ldap-ldapsearch-args
diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el
index fd13b3a0f51..40a1e4bfad3 100644
--- a/lisp/net/quickurl.el
+++ b/lisp/net/quickurl.el
@@ -256,14 +256,16 @@ returned."
;; Main code:
-(defun* quickurl-read (&optional (buffer (current-buffer)))
+(defun* quickurl-read (&optional buffer)
"`read' the URL list from BUFFER into `quickurl-urls'.
+BUFFER, if nil, defaults to current buffer.
Note that this function moves point to `point-min' before doing the `read'
It also restores point after the `read'."
(save-excursion
(setf (point) (point-min))
- (setq quickurl-urls (funcall quickurl-sort-function (read buffer)))))
+ (setq quickurl-urls (funcall quickurl-sort-function
+ (read (or buffer (current-buffer)))))))
(defun quickurl-load-urls ()
"Load the contents of `quickurl-url-file' into `quickurl-urls'."
@@ -298,14 +300,15 @@ Also display a `message' saying what the URL was unless SILENT is non-nil."
(message "Found %s" (quickurl-url-url url))))
;;;###autoload
-(defun* quickurl (&optional (lookup (funcall quickurl-grab-lookup-function)))
+(defun* quickurl (&optional lookup)
"Insert an URL based on LOOKUP.
If not supplied LOOKUP is taken to be the word at point in the current
buffer, this default action can be modifed via
`quickurl-grab-lookup-function'."
(interactive)
- (when lookup
+ (when (or lookup
+ (setq lookup (funcall quickurl-grab-lookup-function)))
(quickurl-load-urls)
(let ((url (quickurl-find-url lookup)))
(if (null url)
@@ -392,14 +395,15 @@ is decided."
(message "Added %s" url))))))
;;;###autoload
-(defun* quickurl-browse-url (&optional (lookup (funcall quickurl-grab-lookup-function)))
+(defun quickurl-browse-url (&optional lookup)
"Browse the URL associated with LOOKUP.
If not supplied LOOKUP is taken to be the word at point in the
current buffer, this default action can be modifed via
`quickurl-grab-lookup-function'."
(interactive)
- (when lookup
+ (when (or lookup
+ (setq lookup (funcall quickurl-grab-lookup-function)))
(quickurl-load-urls)
(let ((url (quickurl-find-url lookup)))
(if url
diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el
index dac6f228cd6..40a28494774 100644
--- a/lisp/net/telnet.el
+++ b/lisp/net/telnet.el
@@ -1,6 +1,6 @@
;;; telnet.el --- run a telnet session from within an Emacs buffer
-;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 88, 1992, 94, 2004 Free Software Foundation, Inc.
;; Author: William F. Schelter
;; Maintainer: FSF
@@ -197,18 +197,28 @@ rejecting one login and prompting again for a username and password.")
;;;###autoload (add-hook 'same-window-regexps "\\*telnet-.*\\*\\(\\|<[0-9]+>\\)")
;;;###autoload
-(defun telnet (host)
+(defun telnet (host &optional port)
"Open a network login connection to host named HOST (a string).
+Optional arg PORT specifies alternative port to connect to.
+Interactively, use \\[universal-argument] prefix to be prompted for port number.
+
Communication with HOST is recorded in a buffer `*PROGRAM-HOST*'
where PROGRAM is the telnet program being used. This program
is controlled by the contents of the global variable `telnet-host-properties',
falling back on the value of the global variable `telnet-program'.
Normally input is edited in Emacs and sent a line at a time."
- (interactive "sOpen connection to host: ")
+ (interactive (list (read-string "Open connection to host: ")
+ (cond
+ ((null current-prefix-arg) nil)
+ ((consp current-prefix-arg) (read-string "Port: "))
+ (t (prefix-numeric-value current-prefix-arg)))))
+ (if (and port (numberp port))
+ (setq port (int-to-string port)))
(let* ((comint-delimiter-argument-list '(?\ ?\t))
(properties (cdr (assoc host telnet-host-properties)))
(telnet-program (if properties (car properties) telnet-program))
- (name (concat telnet-program "-" (comint-arguments host 0 nil) ))
+ (hname (if port (concat host ":" port) host))
+ (name (concat telnet-program "-" (comint-arguments hname 0 nil) ))
(buffer (get-buffer (concat "*" name "*")))
(telnet-options (if (cdr properties) (cons "-l" (cdr properties))))
process)
@@ -221,29 +231,22 @@ Normally input is edited in Emacs and sent a line at a time."
;; Don't send the `open' cmd till telnet is ready for it.
(accept-process-output process)
(erase-buffer)
- (send-string process (concat "open " host "\n"))
+ (send-string process (concat "open " host
+ (if port " " "") (or port "")
+ "\n"))
(telnet-mode)
(setq comint-input-sender 'telnet-simple-send)
(setq telnet-count telnet-initial-count))))
(put 'telnet-mode 'mode-class 'special)
-(defun telnet-mode ()
+(define-derived-mode telnet-mode comint-mode "Telnet"
"This mode is for using telnet (or rsh) from a buffer to another host.
It has most of the same commands as comint-mode.
There is a variable ``telnet-interrupt-string'' which is the character
sent to try to stop execution of a job on the remote host.
-Data is sent to the remote host when RET is typed.
-
-\\{telnet-mode-map}
-"
- (interactive)
- (comint-mode)
- (setq major-mode 'telnet-mode
- mode-name "Telnet"
- comint-prompt-regexp telnet-prompt-pattern)
- (use-local-map telnet-mode-map)
- (run-hooks 'telnet-mode-hook))
+Data is sent to the remote host when RET is typed."
+ (set (make-local-variable 'comint-prompt-regexp) telnet-prompt-pattern))
;;;###autoload (add-hook 'same-window-regexps "\\*rsh-[^-]*\\*\\(\\|<[0-9]*>\\)")
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index ab6ad3310c1..cca01d169b6 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -38,6 +38,19 @@
(or (>= emacs-major-version 20)
(load "cl-seq")))
+;; Avoid byte-compiler warnings if the byte-compiler supports this.
+;; Currently, XEmacs supports this.
+(eval-when-compile
+ (when (fboundp 'byte-compiler-options)
+ (let (unused-vars) ; Pacify Emacs byte-compiler
+ (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
+ (byte-compiler-options (warnings (- unused-vars))))))
+
+;; XEmacs byte-compiler raises warning abouts `last-coding-system-used'.
+(eval-when-compile
+ (unless (boundp 'last-coding-system-used)
+ (defvar last-coding-system-used nil)))
+
;; Define SMB method ...
(defcustom tramp-smb-method "smb"
"*Method to connect SAMBA and M$ SMB servers."
@@ -131,6 +144,7 @@ This variable is local to each buffer.")
(file-executable-p . tramp-smb-handle-file-exists-p)
(file-exists-p . tramp-smb-handle-file-exists-p)
(file-local-copy . tramp-smb-handle-file-local-copy)
+ (file-remote-p . tramp-handle-file-remote-p)
(file-modes . tramp-handle-file-modes)
(file-name-all-completions . tramp-smb-handle-file-name-all-completions)
;; `file-name-as-directory' performed by default handler
@@ -145,7 +159,7 @@ This variable is local to each buffer.")
(file-symlink-p . tramp-smb-not-handled)
;; `file-truename' performed by default handler
(file-writable-p . tramp-smb-handle-file-writable-p)
- ;; `find-backup-file-name' performed by default handler
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
;; `find-file-noselect' performed by default handler
;; `get-file-buffer' performed by default handler
(insert-directory . tramp-smb-handle-insert-directory)
@@ -990,7 +1004,7 @@ Domain names in USER and port numbers in HOST are acknowledged."
tramp-smb-program args)))
(tramp-message 9 "Started process %s" (process-command p))
- (process-kill-without-query p)
+ (tramp-set-process-query-on-exit-flag p nil)
(set-buffer buffer)
(setq tramp-smb-share share)
diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el
index 1047e62a3cb..d18af101c48 100644
--- a/lisp/net/tramp-uu.el
+++ b/lisp/net/tramp-uu.el
@@ -1,7 +1,7 @@
;;; -*- coding: iso-2022-7bit; -*-
;;; tramp-uu.el --- uuencode in Lisp
-;; Copyright (C) 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;; Author: Kai Gro,A_(Bjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>
;; Keywords: comm, terminals
@@ -63,10 +63,10 @@
(setq c (char-after (point)))
(delete-char 1)
(if (equal c ?=)
- ;; "=" means padding. Insert "`" instead.
- (insert "`")
- (insert (tramp-uu-byte-to-uu-char (tramp-uu-b64-char-to-byte c))))
- (setq i (1+ i))
+ ;; "=" means padding. Insert "`" instead. Not counted for length.
+ (progn (insert "`") (setq len (1- len)))
+ (insert (tramp-uu-byte-to-uu-char (tramp-uu-b64-char-to-byte c)))
+ (setq i (1+ i)))
;; Every 60 characters, add "M" at beginning of line (as
;; length byte) and insert a newline.
(when (zerop (% i 60))
diff --git a/lisp/net/tramp-vc.el b/lisp/net/tramp-vc.el
index ded30f4b09c..839a8702dd9 100644
--- a/lisp/net/tramp-vc.el
+++ b/lisp/net/tramp-vc.el
@@ -1,6 +1,6 @@
;;; tramp-vc.el --- Version control integration for TRAMP.el
-;; Copyright (C) 2000 by Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004 by Free Software Foundation, Inc.
;; Author: Daniel Pittman <daniel@danann.net>
;; Keywords: comm, processes
@@ -38,6 +38,14 @@
(require 'vc-rcs))
(require 'tramp)
+;; Avoid byte-compiler warnings if the byte-compiler supports this.
+;; Currently, XEmacs supports this.
+(eval-when-compile
+ (when (fboundp 'byte-compiler-options)
+ (let (unused-vars) ; Pacify Emacs byte-compiler
+ (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
+ (byte-compiler-options (warnings (- unused-vars))))))
+
;; -- vc --
;; This used to blow away the file-name-handler-alist and reinstall
@@ -163,7 +171,9 @@ Since TRAMP doesn't do async commands yet, this function doesn't, either."
(if vc-command-messages
(message "Running %s on %s..." command file))
(save-current-buffer
- (unless (eq buffer t) (vc-setup-buffer buffer))
+ (unless (eq buffer t)
+ ; Pacify byte-compiler
+ (funcall (symbol-function 'vc-setup-buffer) buffer))
(let ((squeezed nil)
(inhibit-read-only t)
(status 0))
@@ -192,9 +202,10 @@ Since TRAMP doesn't do async commands yet, this function doesn't, either."
(if (integerp status) (format "status %d" status) status))))
(if vc-command-messages
(message "Running %s...OK" command))
- (vc-exec-after
- `(run-hook-with-args
- 'vc-post-command-functions ',command ',localname ',flags))
+ ; Pacify byte-compiler
+ (funcall (symbol-function 'vc-exec-after)
+ `(run-hook-with-args
+ 'vc-post-command-functions ',command ',localname ',flags))
status))))
@@ -325,7 +336,8 @@ Since TRAMP doesn't do async commands yet, this function doesn't, either."
(not want-differences-if-changed))))
(zerop status))
;; New VC. Call `vc-default-workfile-unchanged-p'.
- (vc-default-workfile-unchanged-p (vc-backend file) filename)))
+ (funcall (symbol-function 'vc-default-workfile-unchanged-p)
+ (vc-backend filename) filename)))
(defadvice vc-workfile-unchanged-p
(around tramp-advice-vc-workfile-unchanged-p
@@ -391,14 +403,15 @@ filename we are thinking about..."
;; Pacify byte-compiler; this symbol is bound in the calling
;; function. CCC: Maybe it would be better to move the
;; boundness-checking into this function?
- (let ((file (symbol-value 'file))
- (remote-uid
- ;; With Emacs 21.4, `file-attributes' has got an optional parameter
- ;; ID-FORMAT. Handle this case backwards compatible.
- (if (and (functionp 'subr-arity)
- (= 2 (cdr (subr-arity (symbol-function 'file-attributes)))))
- (nth 2 (file-attributes file 'integer))
- (nth 2 (file-attributes file)))))
+ (let* ((file (symbol-value 'file))
+ (remote-uid
+ ;; With Emacs 21.4, `file-attributes' has got an optional parameter
+ ;; ID-FORMAT. Handle this case backwards compatible.
+ (if (and (functionp 'subr-arity)
+ (= 2 (cdr (funcall (symbol-function 'subr-arity)
+ (symbol-function 'file-attributes)))))
+ (nth 2 (file-attributes file 'integer))
+ (nth 2 (file-attributes file)))))
(if (and uid (/= uid remote-uid))
(error "tramp-handle-vc-user-login-name cannot map a uid to a name")
(let* ((v (tramp-dissect-file-name (tramp-handle-expand-file-name file)))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index cd6ed337927..769ad3f51f6 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -135,11 +135,25 @@ Nil means to use a separate filename syntax for Tramp.")
(unless (boundp 'custom-print-functions)
(defvar custom-print-functions nil)) ; not autoloaded before Emacs 20.4
-;; Avoid bytecompiler warnings if the byte-compiler supports this.
+;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
(when (fboundp 'byte-compiler-options)
- (byte-compiler-options (warnings (- unused-vars)))))
+ (let (unused-vars) ; Pacify Emacs byte-compiler
+ (defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
+ (byte-compiler-options (warnings (- unused-vars))))))
+
+;; `directory-sep-char' is an obsolete variable in Emacs. But it is
+;; used in XEmacs, so we set it here and there. The following is needed
+;; to pacify Emacs byte-compiler.
+(eval-when-compile
+ (when (boundp 'byte-compile-not-obsolete-var)
+ (setq byte-compile-not-obsolete-var 'directory-sep-char)))
+
+;; XEmacs byte-compiler raises warning abouts `last-coding-system-used'.
+(eval-when-compile
+ (unless (boundp 'last-coding-system-used)
+ (defvar last-coding-system-used nil)))
;;; User Customizable Internal Variables:
@@ -157,6 +171,49 @@ Nil means to use a separate filename syntax for Tramp.")
:group 'tramp
:type 'boolean)
+;; Emacs case
+(eval-and-compile
+ (when (boundp 'backup-directory-alist)
+ (defcustom tramp-backup-directory-alist nil
+ "Alist of filename patterns and backup directory names.
+Each element looks like (REGEXP . DIRECTORY), with the same meaning like
+in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY
+is a local file name, the backup directory is prepended with Tramp file
+name prefix \(multi-method, method, user, host\) of file.
+
+\(setq tramp-backup-directory-alist backup-directory-alist\)
+
+gives the same backup policy for Tramp files on their hosts like the
+policy for local files."
+ :group 'tramp
+ :type '(repeat (cons (regexp :tag "Regexp matching filename")
+ (directory :tag "Backup directory name"))))))
+
+;; XEmacs case. We cannot check for `bkup-backup-directory-info', because
+;; the package "backup-dir" might not be loaded yet.
+(eval-and-compile
+ (when (featurep 'xemacs)
+ (defcustom tramp-bkup-backup-directory-info nil
+ "*Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...))
+It has the same meaning like `bkup-backup-directory-info' from package
+`backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local
+file name, the backup directory is prepended with Tramp file name prefix
+\(multi-method, method, user, host\) of file.
+
+\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info\)
+
+gives the same backup policy for Tramp files on their hosts like the
+policy for local files."
+ :type '(repeat
+ (list (regexp :tag "File regexp")
+ (string :tag "Backup Dir")
+ (set :inline t
+ (const ok-create)
+ (const full-path)
+ (const prepend-name)
+ (const search-upward))))
+ :group 'tramp)))
+
(defcustom tramp-auto-save-directory nil
"*Put auto-save files in this directory, if set.
The idea is to use a local directory so that auto-saving is faster."
@@ -854,6 +911,16 @@ The answer will be provided by `tramp-action-terminal', which see."
:group 'tramp
:type 'regexp)
+(defcustom tramp-process-alive-regexp
+ ""
+ "Regular expression indicating a process has finished.
+In fact this expression is empty by intention, it will be used only to
+check regularly the status of the associated process.
+The answer will be provided by `tramp-action-process-alive' and
+`tramp-action-out-of-band', which see."
+ :group 'tramp
+ :type 'regexp)
+
(defcustom tramp-temp-name-prefix "tramp."
"*Prefix to use for temporary files.
If this is a relative file name (such as \"tramp.\"), it is considered
@@ -1080,7 +1147,7 @@ Also see `tramp-file-name-structure'."
;;;###autoload
(defconst tramp-completion-file-name-regexp-unified
- "^/[^/]*$"
+ "^/$\\|^/[^/:][^/]*$"
"Value for `tramp-completion-file-name-regexp' for unified remoting.
Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and
Tramp. See `tramp-file-name-structure-unified' for more explanations.")
@@ -1222,7 +1289,8 @@ but it might be slow on large directories."
(tramp-wrong-passwd-regexp tramp-action-permission-denied)
(tramp-yesno-prompt-regexp tramp-action-yesno)
(tramp-yn-prompt-regexp tramp-action-yn)
- (tramp-terminal-prompt-regexp tramp-action-terminal))
+ (tramp-terminal-prompt-regexp tramp-action-terminal)
+ (tramp-process-alive-regexp tramp-action-process-alive))
"List of pattern/action pairs.
Whenever a pattern matches, the corresponding action is performed.
Each item looks like (PATTERN ACTION).
@@ -1237,12 +1305,23 @@ corresponding PATTERN matches, the ACTION function is called."
:group 'tramp
:type '(repeat (list variable function)))
+(defcustom tramp-actions-copy-out-of-band
+ '((tramp-password-prompt-regexp tramp-action-password)
+ (tramp-wrong-passwd-regexp tramp-action-permission-denied)
+ (tramp-process-alive-regexp tramp-action-out-of-band))
+ "List of pattern/action pairs.
+This list is used for copying/renaming with out-of-band methods.
+See `tramp-actions-before-shell' for more info."
+ :group 'tramp
+ :type '(repeat (list variable function)))
+
(defcustom tramp-multi-actions
'((tramp-password-prompt-regexp tramp-multi-action-password)
(tramp-login-prompt-regexp tramp-multi-action-login)
(shell-prompt-pattern tramp-multi-action-succeed)
(tramp-shell-prompt-pattern tramp-multi-action-succeed)
- (tramp-wrong-passwd-regexp tramp-multi-action-permission-denied))
+ (tramp-wrong-passwd-regexp tramp-multi-action-permission-denied)
+ (tramp-process-alive-regexp tramp-action-process-alive))
"List of pattern/action pairs.
This list is used for each hop in multi-hop connections.
See `tramp-actions-before-shell' for more info."
@@ -1250,7 +1329,8 @@ See `tramp-actions-before-shell' for more info."
:type '(repeat (list variable function)))
(defcustom tramp-initial-commands
- '("unset correct"
+ '("unset HISTORY"
+ "unset correct"
"unset autocorrect")
"List of commands to send to the first remote shell that we see.
These commands will be sent to any shell, and thus they should be
@@ -1326,7 +1406,8 @@ the visited file modtime.")
(defvar tramp-md5-function
(cond ((and (require 'md5) (fboundp 'md5)) 'md5)
((fboundp 'md5-encode)
- (lambda (x) (base64-encode-string (md5-encode x))))
+ (lambda (x) (base64-encode-string
+ (funcall (symbol-function 'md5-encode) x))))
(t (error "Coulnd't find an `md5' function")))
"Function to call for running the MD5 algorithm.")
@@ -1464,7 +1545,7 @@ some systems don't, and for them we have this shell function.")
;; The device number is returned as "-1", because there will be a virtual
;; device number set in `tramp-handle-file-attributes'
(defconst tramp-perl-file-attributes "\
-($f, $n) = @ARGV;
+\($f, $n) = @ARGV;
@s = lstat($f);
if (($s[2] & 0170000) == 0120000) { $l = readlink($f); $l = \"\\\"$l\\\"\"; }
elsif (($s[2] & 0170000) == 040000) { $l = \"t\"; }
@@ -1628,6 +1709,14 @@ This is used to map a mode number to a permission string.")
'undecided-dos)
"Some Emacsen know the `dos' coding system, others need `undecided-dos'.")
+(defvar tramp-last-cmd nil
+ "Internal Tramp variable recording the last command sent.
+This variable is buffer-local in every buffer.")
+(make-variable-buffer-local 'tramp-last-cmd)
+
+(defvar tramp-process-echoes nil
+ "Whether to process echoes from the remote shell.")
+
(defvar tramp-last-cmd-time nil
"Internal Tramp variable recording the time when the last cmd was sent.
This variable is buffer-local in every buffer.")
@@ -1638,7 +1727,8 @@ This variable is buffer-local in every buffer.")
(defvar tramp-feature-write-region-fix
(when (fboundp 'find-operation-coding-system)
(let ((file-coding-system-alist '(("test" emacs-mule))))
- (find-operation-coding-system 'write-region 0 0 "" nil "test")))
+ (funcall (symbol-function 'find-operation-coding-system)
+ 'write-region 0 0 "" nil "test")))
"Internal variable to say if `write-region' chooses the right coding.
Older versions of Emacs chose the coding system for `write-region' based
on the FILENAME argument, even if VISIT was a string.")
@@ -1682,8 +1772,10 @@ on the FILENAME argument, even if VISIT was a string.")
(insert-directory . tramp-handle-insert-directory)
(expand-file-name . tramp-handle-expand-file-name)
(file-local-copy . tramp-handle-file-local-copy)
+ (file-remote-p . tramp-handle-file-remote-p)
(insert-file-contents . tramp-handle-insert-file-contents)
(write-region . tramp-handle-write-region)
+ (find-backup-file-name . tramp-handle-find-backup-file-name)
(unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
(dired-compress-file . tramp-handle-dired-compress-file)
(dired-call-process . tramp-handle-dired-call-process)
@@ -1756,8 +1848,8 @@ remaining args passed to `tramp-message'."
Calls `line-end-position' or `point-at-eol' if defined, else
own implementation."
(cond
- ((fboundp 'line-end-position) (funcall 'line-end-position))
- ((fboundp 'point-at-eol) (funcall 'point-at-eol))
+ ((fboundp 'line-end-position) (funcall (symbol-function 'line-end-position)))
+ ((fboundp 'point-at-eol) (funcall (symbol-function 'point-at-eol)))
(t (save-excursion (end-of-line) (point)))))
(defmacro with-parsed-tramp-file-name (filename var &rest body)
@@ -1790,6 +1882,18 @@ If VAR is nil, then we bind `v' to the structure and `multi-method',
,@body))
(put 'with-parsed-tramp-file-name 'lisp-indent-function 2)
+;; To be activated for debugging containing this macro
+(def-edebug-spec with-parsed-tramp-file-name t)
+
+(defmacro tramp-let-maybe (variable value &rest body)
+ "Let-bind VARIABLE to VALUE in BODY, but only if VARIABLE is not obsolete.
+BODY is executed whether or not the variable is obsolete.
+The intent is to protect against `obsolete variable' warnings."
+ `(if (get ',variable 'byte-obsolete-variable)
+ (progn ,@body)
+ (let ((,variable ,value))
+ ,@body)))
+(put 'tramp-let-maybe 'lisp-indent-function 2)
;;; Config Manipulation Functions:
@@ -1953,8 +2057,8 @@ target of the symlink differ."
"Like `file-truename' for tramp files."
(with-parsed-tramp-file-name filename nil
(let* ((steps (tramp-split-string localname "/"))
- (localnamedir (let ((directory-sep-char ?/))
- (file-name-as-directory localname)))
+ (localnamedir (tramp-let-maybe directory-sep-char ?/ ;for XEmacs
+ (file-name-as-directory localname)))
(is-dir (string= localname localnamedir))
(thisstep nil)
(numchase 0)
@@ -2711,7 +2815,7 @@ and `rename'. FILENAME and NEWNAME must be absolute file names."
;; matter which filename handlers are used for the
;; source and target file.
(t
- (tramp-do-copy-or-rename-via-buffer
+ (tramp-do-copy-or-rename-file-via-buffer
op filename newname keep-date))))
;; One file is a Tramp file, the other one is local.
@@ -2727,14 +2831,14 @@ and `rename'. FILENAME and NEWNAME must be absolute file names."
(tramp-do-copy-or-rename-file-out-of-band
op filename newname keep-date)
;; Use the generic method via a Tramp buffer.
- (tramp-do-copy-or-rename-via-buffer op filename newname keep-date)))
+ (tramp-do-copy-or-rename-file-via-buffer
+ op filename newname keep-date)))
(t
;; One of them must be a Tramp file.
(error "Tramp implementation says this cannot happen")))))
-;; CCC: implement keep-date if possible -- via touch?
-(defun tramp-do-copy-or-rename-via-buffer (op filename newname keep-date)
+(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date)
"Use an Emacs buffer to copy or rename a file.
First arg OP is either `copy' or `rename' and indicates the operation.
FILENAME is the source file, NEWNAME the target file.
@@ -2754,10 +2858,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME."
(jka-compr-inhibit t))
(write-region (point-min) (point-max) newname))
;; KEEP-DATE handling.
- (when (and keep-date
- (not (null modtime))
- (not (equal modtime '(0 0))))
- (tramp-touch newname modtime)))
+ (when keep-date
+ (when (and (not (null modtime))
+ (not (equal modtime '(0 0))))
+ (tramp-touch newname modtime))
+ (set-file-modes newname (file-modes filename))))
;; If the operation was `rename', delete the original file.
(unless (eq op 'copy)
(delete-file filename))))
@@ -2791,12 +2896,12 @@ If KEEP-DATE is non-nil, preserve the time stamp when copying."
"Invoke rcp program to copy.
One of FILENAME and NEWNAME must be a Tramp name, the other must
be a local filename. The method used must be an out-of-band method."
- (let ((trampbuf (get-buffer-create "*tramp output*"))
- (t1 (tramp-tramp-file-p filename))
+ (let ((t1 (tramp-tramp-file-p filename))
(t2 (tramp-tramp-file-p newname))
v1-multi-method v1-method v1-user v1-host v1-localname
v2-multi-method v2-method v2-user v2-host v2-localname
- method copy-program copy-args source target)
+ multi-method method user host copy-program copy-args
+ source target trampbuf)
;; Check which ones of source and target are Tramp files.
;; We cannot invoke `with-parsed-tramp-file-name';
@@ -2808,8 +2913,11 @@ be a local filename. The method used must be an out-of-band method."
v1-user l-user
v1-host l-host
v1-localname l-localname
+ multi-method l-multi-method
method (tramp-find-method
v1-multi-method v1-method v1-user v1-host)
+ user l-user
+ host l-host
copy-program (tramp-get-method-parameter
v1-multi-method method
v1-user v1-host 'tramp-copy-program)
@@ -2825,8 +2933,11 @@ be a local filename. The method used must be an out-of-band method."
v2-user l-user
v2-host l-host
v2-localname l-localname
+ multi-method l-multi-method
method (tramp-find-method
v2-multi-method v2-method v2-user v2-host)
+ user l-user
+ host l-host
copy-program (tramp-get-method-parameter
v2-multi-method method
v2-user v2-host 'tramp-copy-program)
@@ -2871,24 +2982,29 @@ be a local filename. The method used must be an out-of-band method."
v2-user v2-host 'tramp-copy-keep-date-arg)
copy-args))))
- (setq copy-args (append copy-args (list source target)))
+ (setq copy-args (append copy-args (list source target))
+ trampbuf (generate-new-buffer
+ (tramp-buffer-name multi-method method user host)))
- ;; Use rcp-like program for file transfer.
- (tramp-message
- 5 "Transferring %s to file %s..." filename newname)
- (save-excursion (set-buffer trampbuf) (erase-buffer))
- (unless (equal
- 0
- (apply #'call-process copy-program
- nil trampbuf nil copy-args))
- (pop-to-buffer trampbuf)
- (error
- (concat
- "tramp-do-copy-or-rename-file-out-of-band: `%s' didn't work, "
- "see buffer `%s' for details")
- copy-program trampbuf))
- (tramp-message
- 5 "Transferring %s to file %s...done" filename newname)
+ ;; Use an asynchronous process. By this, password can be handled.
+ (save-excursion
+ (set-buffer trampbuf)
+ (setq tramp-current-multi-method multi-method
+ tramp-current-method method
+ tramp-current-user user
+ tramp-current-host host)
+ (tramp-message
+ 5 "Transferring %s to file %s..." filename newname)
+
+ ;; Use rcp-like program for file transfer.
+ (let ((p (apply 'start-process (buffer-name trampbuf) trampbuf
+ copy-program copy-args)))
+ (tramp-set-process-query-on-exit-flag p nil)
+ (tramp-process-actions p multi-method method user host
+ tramp-actions-copy-out-of-band))
+ (kill-buffer trampbuf)
+ (tramp-message
+ 5 "Transferring %s to file %s...done" filename newname))
;; If the operation was `rename', delete the original file.
(unless (eq op 'copy)
@@ -3012,7 +3128,8 @@ This is like `dired-recursive-delete-directory' for tramp files."
multi-method method user host
(concat (nth 2 suffix) " " localname)))
(message "Uncompressing %s...done" file)
- (dired-remove-file file)
+ ;; `dired-remove-file' is not defined in XEmacs
+ (funcall (symbol-function 'dired-remove-file) file)
(string-match (car suffix) file)
(concat (substring file 0 (match-beginning 0)))))
(t
@@ -3023,7 +3140,8 @@ This is like `dired-recursive-delete-directory' for tramp files."
multi-method method user host
(concat "gzip -f " localname)))
(message "Compressing %s...done" file)
- (dired-remove-file file)
+ ;; `dired-remove-file' is not defined in XEmacs
+ (funcall (symbol-function 'dired-remove-file) file)
(cond ((file-exists-p (concat file ".gz"))
(concat file ".gz"))
((file-exists-p (concat file ".z"))
@@ -3091,12 +3209,10 @@ This is like `dired-recursive-delete-directory' for tramp files."
(format "%s %s %s"
(tramp-get-ls-command multi-method method user host)
switches
- (if full-directory-p
- ;; Add "/." to make sure we got complete dir
- ;; listing for symlinks, too.
- (concat (file-name-as-directory
- (file-name-nondirectory localname)) ".")
- (file-name-nondirectory localname)))))
+ (if wildcard
+ localname
+ (tramp-shell-quote-argument
+ (file-name-nondirectory localname))))))
(sit-for 1) ;needed for rsh but not ssh?
(tramp-wait-for-output))
;; The following let-binding is used by code that's commented
@@ -3196,7 +3312,7 @@ the result will be a local, non-Tramp, filename."
;; expand-file-name (this does "/./" and "/../"). We bind
;; directory-sep-char here for XEmacs on Windows, which
;; would otherwise use backslash.
- (let ((directory-sep-char ?/))
+ (tramp-let-maybe directory-sep-char ?/
(tramp-make-tramp-file-name
multi-method (or method (tramp-find-default-method user host))
user host
@@ -3361,7 +3477,6 @@ This will break if COMMAND prints a newline, followed by the value of
filename))
(setq tmpfil (tramp-make-temp-file))
-
(cond ((tramp-method-out-of-band-p multi-method method user host)
;; `copy-file' handles out-of-band methods
(copy-file filename tmpfil t t))
@@ -3418,11 +3533,16 @@ This will break if COMMAND prints a newline, followed by the value of
(delete-file tmpfil2)))
(tramp-message-for-buffer
multi-method method user host
- 5 "Decoding remote file %s...done" filename)))
+ 5 "Decoding remote file %s...done" filename)
+ ;; Set proper permissions.
+ (set-file-modes tmpfil (file-modes filename))))
(t (error "Wrong method specification for `%s'" method)))
tmpfil)))
+(defun tramp-handle-file-remote-p (filename)
+ "Like `file-remote-p' for tramp files."
+ (when (tramp-tramp-file-p filename) t))
(defun tramp-handle-insert-file-contents
(filename &optional visit beg end replace)
@@ -3470,6 +3590,49 @@ This will break if COMMAND prints a newline, followed by the value of
(list (expand-file-name filename)
(second result))))))
+
+(defun tramp-handle-find-backup-file-name (filename)
+ "Like `find-backup-file-name' for tramp files."
+
+ (if (or (and (not (featurep 'xemacs))
+ (not (boundp 'tramp-backup-directory-alist)))
+ (and (featurep 'xemacs)
+ (not (boundp 'tramp-bkup-backup-directory-info))))
+
+ ;; No tramp backup directory alist defined, or nil
+ (tramp-run-real-handler 'find-backup-file-name (list filename))
+
+ (with-parsed-tramp-file-name filename nil
+ (let* ((backup-var
+ (copy-tree
+ (if (featurep 'xemacs)
+ ;; XEmacs case
+ (symbol-value 'tramp-bkup-backup-directory-info)
+ ;; Emacs case
+ (symbol-value 'tramp-backup-directory-alist))))
+
+ ;; We set both variables. It doesn't matter whether it is
+ ;; Emacs or XEmacs
+ (backup-directory-alist backup-var)
+ (bkup-backup-directory-info backup-var))
+
+ (mapcar
+ '(lambda (x)
+ (let ((dir (if (consp (cdr x)) (car (cdr x)) (cdr x))))
+ (when (and (stringp dir)
+ (file-name-absolute-p dir)
+ (not (tramp-file-name-p dir)))
+ ;; Prepend absolute directory names with tramp prefix
+ (if (consp (cdr x))
+ (setcar (cdr x)
+ (tramp-make-tramp-file-name
+ multi-method method user host dir))
+ (setcdr x (tramp-make-tramp-file-name
+ multi-method method user host dir))))))
+ backup-var)
+
+ (tramp-run-real-handler 'find-backup-file-name (list filename))))))
+
;; CCC grok APPEND, LOCKNAME, CONFIRM
(defun tramp-handle-write-region
(start end filename &optional append visit lockname confirm)
@@ -3499,6 +3662,7 @@ This will break if COMMAND prints a newline, followed by the value of
(loc-enc (tramp-get-local-encoding multi-method method user host))
(loc-dec (tramp-get-local-decoding multi-method method user host))
(trampbuf (get-buffer-create "*tramp output*"))
+ (modes (file-modes filename))
;; We use this to save the value of `last-coding-system-used'
;; after writing the tmp file. At the end of the function,
;; we set `last-coding-system-used' to this saved value.
@@ -3519,6 +3683,11 @@ This will break if COMMAND prints a newline, followed by the value of
(if confirm ; don't pass this arg unless defined for backward compat.
(list start end tmpfil append 'no-message lockname confirm)
(list start end tmpfil append 'no-message lockname)))
+ ;; The permissions of the temporary file should be set. If
+ ;; filename does not exist (eq modes nil) it has been renamed to
+ ;; the backup file. This case `save-buffer' handles
+ ;; permissions.
+ (when modes (set-file-modes tmpfil modes))
;; Now, `last-coding-system-used' has the right value. Remember it.
(when (boundp 'last-coding-system-used)
(setq coding-system-used last-coding-system-used))
@@ -3694,10 +3863,10 @@ pass to the OPERATION."
;; We handle here all file primitives. Most of them have the file
;; name as first parameter; nevertheless we check for them explicitly
-;; in order to be be signalled if a new primitive appears. This
+;; in order to be signalled if a new primitive appears. This
;; scenario is needed because there isn't a way to decide by
;; syntactical means whether a foreign method must be called. It would
-;; ease the live if `file-name-handler-alist' would support a decision
+;; ease the life if `file-name-handler-alist' would support a decision
;; function as well but regexp only.
(defun tramp-file-name-for-operation (operation &rest args)
"Return file name related to OPERATION file primitive.
@@ -3711,16 +3880,16 @@ ARGS are the arguments OPERATION has been called with."
'dired-compress-file 'dired-uncache
'file-accessible-directory-p 'file-attributes
'file-directory-p 'file-executable-p 'file-exists-p
- 'file-local-copy 'file-modes 'file-name-as-directory
- 'file-name-directory 'file-name-nondirectory
- 'file-name-sans-versions 'file-ownership-preserved-p
- 'file-readable-p 'file-regular-p 'file-symlink-p
- 'file-truename 'file-writable-p 'find-backup-file-name
- 'find-file-noselect 'get-file-buffer 'insert-directory
- 'insert-file-contents 'load 'make-directory
- 'make-directory-internal 'set-file-modes
- 'substitute-in-file-name 'unhandled-file-name-directory
- 'vc-registered
+ 'file-local-copy 'file-remote-p 'file-modes
+ 'file-name-as-directory 'file-name-directory
+ 'file-name-nondirectory 'file-name-sans-versions
+ 'file-ownership-preserved-p 'file-readable-p
+ 'file-regular-p 'file-symlink-p 'file-truename
+ 'file-writable-p 'find-backup-file-name 'find-file-noselect
+ 'get-file-buffer 'insert-directory 'insert-file-contents
+ 'load 'make-directory 'make-directory-internal
+ 'set-file-modes 'substitute-in-file-name
+ 'unhandled-file-name-directory 'vc-registered
; XEmacs only
'abbreviate-file-name 'create-file-buffer
'dired-file-modtime 'dired-make-compressed-filename
@@ -3789,9 +3958,6 @@ Falls back to normal file name handler if no tramp file name handler exists."
(foreign (apply foreign operation args))
(t (tramp-run-real-handler operation args))))))
-;;;###autoload
-(put 'tramp-file-name-handler 'file-remote-p t) ;for file-remote-p
-
(defun tramp-sh-file-name-handler (operation &rest args)
"Invoke remote-shell Tramp file name handler.
Fall back to normal file name handler if no Tramp handler exists."
@@ -3885,7 +4051,7 @@ necessary anymore."
(list (tramp-handle-expand-file-name name))))))
;; Check for complete.el and override PC-expand-many-files if appropriate.
-(eval-when-compile
+(eval-and-compile
(defun tramp-save-PC-expand-many-files (name))); avoid compiler warning
(defun tramp-setup-complete ()
@@ -3936,11 +4102,14 @@ necessary anymore."
(and (featurep 'xemacs)
(not (event-modifiers last-input-event))
(or (char-equal
- (funcall 'event-to-character last-input-event) ?\?)
+ (funcall (symbol-function 'event-to-character)
+ last-input-event) ?\?)
(char-equal
- (funcall 'event-to-character last-input-event) ?\t)
+ (funcall (symbol-function 'event-to-character)
+ last-input-event) ?\t)
(char-equal
- (funcall 'event-to-character last-input-event) ?\ ))))
+ (funcall (symbol-function 'event-to-character)
+ last-input-event) ?\ ))))
t)))
(defun tramp-completion-handle-file-exists-p (filename)
@@ -4478,17 +4647,24 @@ hosts, or files, disagree."
"Set the last-modified timestamp of the given file.
TIME is an Emacs internal time value as returned by `current-time'."
(let ((touch-time (format-time-string "%Y%m%d%H%M.%S" time)))
- (with-parsed-tramp-file-name file nil
- (let ((buf (tramp-get-buffer multi-method method user host)))
- (unless (zerop (tramp-send-command-and-check
- multi-method method user host
- (format "touch -t %s %s"
- touch-time
- localname)))
- (pop-to-buffer buf)
- (error "tramp-touch: touch failed, see buffer `%s' for details"
- buf))))))
-
+ (if (tramp-tramp-file-p file)
+ (with-parsed-tramp-file-name file nil
+ (let ((buf (tramp-get-buffer multi-method method user host)))
+ (unless (zerop (tramp-send-command-and-check
+ multi-method method user host
+ (format "touch -t %s %s"
+ touch-time
+ localname)))
+ (pop-to-buffer buf)
+ (error "tramp-touch: touch failed, see buffer `%s' for details"
+ buf))))
+ ;; It's a local file
+ (with-temp-buffer
+ (unless (zerop (call-process
+ "touch" nil (current-buffer) nil "-t" touch-time file))
+ (pop-to-buffer (current-buffer))
+ (error "tramp-touch: touch failed"))))))
+
(defun tramp-buffer-name (multi-method method user host)
"A name for the connection buffer for USER at HOST using METHOD."
(if multi-method
@@ -4726,16 +4902,16 @@ otherwise."
"Checks whether the given `ls' executable in one of the dirs groks `-n'.
Returns nil if none was found, else the command is returned."
(let ((dl dirlist)
- (result nil)
- (directory-sep-char ?/)) ;for XEmacs
- ;; It would be better to use the CL function `find', but
- ;; we don't want run-time dependencies on CL.
- (while (and dl (not result))
- (let ((x (concat (file-name-as-directory (car dl)) cmd)))
- (when (tramp-check-ls-command multi-method method user host x)
- (setq result x)))
- (setq dl (cdr dl)))
- result))
+ (result nil))
+ (tramp-let-maybe directory-sep-char ?/ ;for XEmacs
+ ;; It would be better to use the CL function `find', but
+ ;; we don't want run-time dependencies on CL.
+ (while (and dl (not result))
+ (let ((x (concat (file-name-as-directory (car dl)) cmd)))
+ (when (tramp-check-ls-command multi-method method user host x)
+ (setq result x)))
+ (setq dl (cdr dl)))
+ result)))
(defun tramp-find-ls-command (multi-method method user host)
"Finds an `ls' command which groks the `-n' option, returning nil if failed.
@@ -4815,6 +4991,24 @@ The terminal type can be configured with `tramp-terminal-type'."
(process-send-string nil (concat tramp-terminal-type
tramp-rsh-end-of-line)))
+(defun tramp-action-process-alive (p multi-method method user host)
+ "Check whether a process has finished."
+ (unless (memq (process-status p) '(run open))
+ (throw 'tramp-action 'process-died)))
+
+(defun tramp-action-out-of-band (p multi-method method user host)
+ "Check whether an out-of-band copy has finished."
+ (cond ((and (memq (process-status p) '(stop exit))
+ (zerop (process-exit-status p)))
+ (tramp-message 9 "Process has finished.")
+ (throw 'tramp-action 'ok))
+ ((or (and (memq (process-status p) '(stop exit))
+ (not (zerop (process-exit-status p))))
+ (memq (process-status p) '(signal)))
+ (tramp-message 9 "Process has died.")
+ (throw 'tramp-action 'process-died))
+ (t nil)))
+
;; The following functions are specifically for multi connections.
(defun tramp-multi-action-login (p method user host)
@@ -4931,7 +5125,7 @@ The terminal type can be configured with `tramp-terminal-type'."
(erase-buffer)
(tramp-message 10 "Sending command to remote shell: %s"
cmd)
- (tramp-send-command multi-method method user host cmd)
+ (tramp-send-command multi-method method user host cmd nil t)
(tramp-barf-if-no-shell-prompt
p 60 "Remote shell command failed: %s" cmd))
(erase-buffer)))
@@ -4991,7 +5185,7 @@ Maybe the different regular expressions need to be tuned.
user host 'tramp-login-args)))
(found nil)
(pw nil))
- (process-kill-without-query p)
+ (tramp-set-process-query-on-exit-flag p nil)
(set-buffer (tramp-get-buffer multi-method method user host))
(erase-buffer)
(tramp-process-actions p multi-method method user host
@@ -5014,12 +5208,6 @@ Recognition of the remote shell prompt is based on the variables
`shell-prompt-pattern' and `tramp-shell-prompt-pattern' which must be
set up correctly.
-Please note that it is NOT possible to use this connection method with
-an out-of-band transfer method if this function asks the user for a
-password! You must use an inline transfer method in this case.
-Sadly, the transfer method cannot be switched on the fly, instead you
-must specify the right method in the file name.
-
Kludgy feature: if HOST has the form \"xx#yy\", then yy is assumed to
be a port number for ssh, and \"-p yy\" will be added to the list of
arguments, and xx will be used as the host name to connect to.
@@ -5064,7 +5252,7 @@ arguments, and xx will be used as the host name to connect to.
(apply #'start-process bufnam buf login-program
host login-args)))
(found nil))
- (process-kill-without-query p)
+ (tramp-set-process-query-on-exit-flag p nil)
(set-buffer buf)
(tramp-process-actions p multi-method method user host
@@ -5125,7 +5313,7 @@ prompt than you do, so it is not at all unlikely that the variable
user host 'tramp-login-args))))
(found nil)
(pw nil))
- (process-kill-without-query p)
+ (tramp-set-process-query-on-exit-flag p nil)
(set-buffer (tramp-get-buffer multi-method method user host))
(tramp-process-actions p multi-method method user host
tramp-actions-before-shell)
@@ -5178,7 +5366,7 @@ log in as u2 to h2."
tramp-multi-sh-program))
(num-hops (length method))
(i 0))
- (process-kill-without-query p)
+ (tramp-set-process-query-on-exit-flag p nil)
(tramp-message 9 "Waiting 60s for local shell to come up...")
(unless (tramp-wait-for-regexp
p 60 (format "\\(%s\\)\\'\\|\\(%s\\)\\'"
@@ -5298,12 +5486,16 @@ nil."
(with-timeout (timeout)
(while (not found)
(accept-process-output proc 1)
+ (unless (memq (process-status proc) '(run open))
+ (error "Process has died"))
(goto-char (point-min))
(setq found (when (re-search-forward regexp nil t)
(tramp-match-string-list)))))))
(t
(while (not found)
(accept-process-output proc 1)
+ (unless (memq (process-status proc) '(run open))
+ (error "Process has died"))
(goto-char (point-min))
(setq found (when (re-search-forward regexp nil t)
(tramp-match-string-list))))))
@@ -5358,7 +5550,7 @@ Uses PROMPT as a prompt and sends the password to process P."
;; HHH: Not Changed. This might handle the case where USER is not
;; given in the "File name" very poorly. Then, the local
-;; variable tramp-current user will be set to nil.
+;; variable tramp-current-user will be set to nil.
(defun tramp-pre-connection (multi-method method user host)
"Do some setup before actually logging in.
METHOD, USER and HOST specify the connection."
@@ -5412,6 +5604,10 @@ to set up. METHOD, USER and HOST specify the connection."
(tramp-send-command-internal multi-method method user host
"stty -inlcr -echo kill '^U'")
(erase-buffer)
+ ;; Ignore garbage after stty command.
+ (tramp-send-command-internal multi-method method user host
+ "echo foo")
+ (erase-buffer)
(tramp-send-command-internal multi-method method user host
"TERM=dumb; export TERM")
;; Try to set up the coding system correctly.
@@ -5449,9 +5645,10 @@ to set up. METHOD, USER and HOST specify the connection."
"stty -onlcr"))))
(erase-buffer)
(tramp-message
- 9 "Waiting 30s for `HISTFILE=$HOME/.tramp_history; HISTSIZE=1'")
- (tramp-send-command-internal multi-method method user host
- "HISTFILE=$HOME/.tramp_history; HISTSIZE=1")
+ 9 "Waiting 30s for `HISTFILE=$HOME/.tramp_history; HISTSIZE=1; export HISTFILE; export HISTSIZE'")
+ (tramp-send-command-internal
+ multi-method method user host
+ "HISTFILE=$HOME/.tramp_history; HISTSIZE=1; export HISTFILE; export HISTSIZE")
(erase-buffer)
(tramp-message 9 "Waiting 30s for `set +o vi +o emacs'")
(tramp-send-command-internal multi-method method user host
@@ -5858,6 +6055,7 @@ connection. This is meant to be used from
(or neveropen
(tramp-maybe-open-connection multi-method method user host))
(setq tramp-last-cmd-time (current-time))
+ (setq tramp-last-cmd command)
(when tramp-debug-buffer
(save-excursion
(set-buffer (tramp-get-debug-buffer multi-method method user host))
@@ -5886,6 +6084,7 @@ Sends COMMAND, then waits 30 seconds for shell prompt."
(let ((proc (get-buffer-process (current-buffer)))
(found nil)
(start-time (current-time))
+ (start-point (point))
(end-of-output (concat "^"
(regexp-quote tramp-end-of-output)
"\r?$")))
@@ -5905,12 +6104,16 @@ Sends COMMAND, then waits 30 seconds for shell prompt."
(with-timeout (timeout)
(while (not found)
(accept-process-output proc 1)
+ (unless (memq (process-status proc) '(run open))
+ (error "Process has died"))
(goto-char (point-max))
(forward-line -1)
(setq found (looking-at end-of-output))))))
(t
(while (not found)
(accept-process-output proc 1)
+ (unless (memq (process-status proc) '(run open))
+ (error "Process has died"))
(goto-char (point-max))
(forward-line -1)
(setq found (looking-at end-of-output))))))
@@ -5920,6 +6123,12 @@ Sends COMMAND, then waits 30 seconds for shell prompt."
(goto-char (point-max))
(forward-line -2)
(delete-region (point) (point-max)))
+ ;; If processing echoes, look for it in the first line and delete.
+ (when tramp-process-echoes
+ (save-excursion
+ (goto-char start-point)
+ (when (looking-at (regexp-quote tramp-last-cmd))
+ (delete-region (point) (forward-line 1)))))
;; Add output to debug buffer if appropriate.
(when tramp-debug-buffer
(append-to-buffer
@@ -6325,9 +6534,7 @@ If both MULTI-METHOD and METHOD are nil, do a lookup in
(format "%s:%s" host localname)))
(defun tramp-method-out-of-band-p (multi-method method user host)
- "Return t if this is an out-of-band method, nil otherwise.
-It is important to check for this condition, since it is not possible
-to enter a password for the `tramp-copy-program'."
+ "Return t if this is an out-of-band method, nil otherwise."
(tramp-get-method-parameter
multi-method
(tramp-find-method multi-method method user host)
@@ -6502,7 +6709,10 @@ Invokes `password-read' if available, `read-passwd' else."
(if (functionp 'password-read)
(let* ((user (or tramp-current-user (user-login-name)))
(host (or tramp-current-host (system-name)))
- (key (concat user "@" host))
+ (key (if (and (stringp user) (stringp host))
+ (concat user "@" host)
+ (concat "[" (mapconcat 'identity user "/") "]@["
+ (mapconcat 'identity host "/") "]")))
(password (apply #'password-read (list prompt key))))
(apply #'password-cache-add (list key password))
password)
@@ -6581,6 +6791,16 @@ If you want to use it for something else, you'll have to check whether
it does the right thing."
(delete "" (split-string string pattern)))
+(defun tramp-set-process-query-on-exit-flag (process flag)
+ "Specify if query is needed for process when Emacs is exited.
+If the second argument flag is non-nil, Emacs will query the user before
+exiting if process is running."
+ (if (fboundp 'set-process-query-on-exit-flag)
+ (set-process-query-on-exit-flag process flag)
+ (funcall (symbol-function 'process-kill-without-query)
+ process flag)))
+
+
;; ------------------------------------------------------------
;; -- Kludges section --
;; ------------------------------------------------------------
@@ -6714,6 +6934,8 @@ Only works for Bourne-like shells."
tramp-wrong-passwd-regexp
tramp-yesno-prompt-regexp
tramp-yn-prompt-regexp
+ tramp-terminal-prompt-regexp
+ tramp-out-of-band-prompt-regexp
tramp-temp-name-prefix
tramp-file-name-structure
tramp-file-name-regexp
@@ -6725,10 +6947,15 @@ Only works for Bourne-like shells."
tramp-end-of-output
tramp-coding-commands
tramp-actions-before-shell
+ tramp-actions-copy-out-of-band
tramp-multi-actions
tramp-terminal-type
tramp-shell-prompt-pattern
tramp-chunksize
+ ,(when (boundp 'tramp-backup-directory-alist)
+ 'tramp-backup-directory-alist)
+ ,(when (boundp 'tramp-bkup-backup-directory-info)
+ 'tramp-bkup-backup-directory-info)
;; Non-tramp variables of interest
shell-prompt-pattern
@@ -6737,6 +6964,14 @@ Only works for Bourne-like shells."
backup-by-copying-when-mismatch
,(when (boundp 'backup-by-copying-when-privileged-mismatch)
'backup-by-copying-when-privileged-mismatch)
+ ,(when (boundp 'password-cache)
+ 'password-cache)
+ ,(when (boundp 'password-cache-expiry)
+ 'password-cache-expiry)
+ ,(when (boundp 'backup-directory-alist)
+ 'backup-directory-alist)
+ ,(when (boundp 'bkup-backup-directory-info)
+ 'bkup-backup-directory-info)
file-name-handler-alist)
nil ; pre-hook
nil ; post-hook
@@ -6799,7 +7034,6 @@ report.
;; * Rewrite `tramp-shell-quote-argument' to abstain from using
;; `shell-quote-argument'.
;; * Completion gets confused when you leave out the method name.
-;; * Support `dired-compress-file' filename handler.
;; * In Emacs 21, `insert-directory' shows total number of bytes used
;; by the files in that directory. Add this here.
;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman)
@@ -6820,19 +7054,12 @@ report.
;; if it does show files when run locally.
;; * Allow correction of passwords, if the remote end allows this.
;; (Mark Hershberger)
-;; * Make sure permissions of tmp file are good.
-;; (Nelson Minar <nelson@media.mit.edu>)
-;; * Grok passwd prompts with scp? (David Winter
-;; <winter@nevis1.nevis.columbia.edu>). Maybe just do `ssh -l user
-;; host', then wait a while for the passwd or passphrase prompt. If
-;; there is one, remember the passwd/phrase.
;; * How to deal with MULE in `insert-file-contents' and `write-region'?
;; * Do asynchronous `shell-command's.
;; * Grok `append' parameter for `write-region'.
;; * Test remote ksh or bash for tilde expansion in `tramp-find-shell'?
;; * abbreviate-file-name
;; * grok ~ in tramp-remote-path (Henrik Holm <henrikh@tele.ntnu.no>)
-;; * `C' in dired gives error `not tramp file name'.
;; * Also allow to omit user names when doing multi-hop. Not sure yet
;; what the user names should default to, though.
;; * better error checking. At least whenever we see something
@@ -6848,9 +7075,7 @@ report.
;; (Francesco Potort,Al(B)
;; * Should we set PATH ourselves or should we rely on the remote end
;; to do it?
-;; * Do the autoconf thing.
;; * Make it work for XEmacs 20, which is missing `with-timeout'.
-;; * Allow non-Unix remote systems. (More a long-term thing.)
;; * Make it work for different encodings, and for different file name
;; encodings, too. (Daniel Pittman)
;; * Change applicable functions to pass a struct tramp-file-name rather
@@ -6865,13 +7090,6 @@ report.
;; * When editing a remote CVS controlled file as a different user, VC
;; gets confused about the file locking status. Try to find out why
;; the workaround doesn't work.
-;; * When user is running ssh-agent, it would be useful to add the
-;; passwords typed by the user to that agent. This way, the next time
-;; round, the users don't have to type all this in again.
-;; This would be especially useful for start-process, I think.
-;; An easy way to implement start-process is to open a second shell
-;; connection which is inconvenient if the user has to reenter
-;; passwords.
;; * Change `copy-file' to grok the case where the filename handler
;; for the source and the target file are different. Right now,
;; it looks at the source file and then calls that handler, if
@@ -6895,17 +7113,10 @@ report.
;; Functions for file-name-handler-alist:
;; diff-latest-backup-file -- in diff.el
-;; dired-compress-file
;; dired-uncache -- this will be needed when we do insert-directory caching
;; file-name-as-directory -- use primitive?
-;; file-name-directory -- use primitive?
-;; file-name-nondirectory -- use primitive?
;; file-name-sans-versions -- use primitive?
-;; file-newer-than-file-p
-;; find-backup-file-name
;; get-file-buffer -- use primitive
-;; load
-;; unhandled-file-name-directory
;; vc-registered
;;; arch-tag: 3a21a994-182b-48fa-b0cd-c1d9fede424a
diff --git a/lisp/newcomment.el b/lisp/newcomment.el
index 924cf0ed8c4..22713f87a96 100644
--- a/lisp/newcomment.el
+++ b/lisp/newcomment.el
@@ -356,7 +356,7 @@ in strings will not confuse Emacs.")
"Find a comment start between point and LIMIT.
Moves point to inside the comment and returns the position of the
comment-starter. If no comment is found, moves point to LIMIT
-and raises an error or returns nil of NOERROR is non-nil."
+and raises an error or returns nil if NOERROR is non-nil."
(if (not comment-use-syntax)
(if (re-search-forward comment-start-skip limit noerror)
(or (match-end 1) (match-beginning 0))
@@ -392,7 +392,7 @@ and raises an error or returns nil of NOERROR is non-nil."
"Find a comment start between LIMIT and point.
Moves point to inside the comment and returns the position of the
comment-starter. If no comment is found, moves point to LIMIT
-and raises an error or returns nil of NOERROR is non-nil."
+and raises an error or returns nil if NOERROR is non-nil."
;; FIXME: If a comment-start appears inside a comment, we may erroneously
;; stop there. This can be rather bad in general, but since
;; comment-search-backward is only used to find the comment-column (in
@@ -873,17 +873,17 @@ indentation to be kept as it was before narrowing."
(setq ,bindent (- ,bindent n)))))))))))
(defun comment-region-internal (beg end cs ce
- &optional ccs cce block lines indent)
+ &optional ccs cce block lines indent)
"Comment region BEG .. END.
-CS and CE are the comment start resp end string.
-CCS and CCE are the comment continuation strings for the start resp end
-of lines (default to CS and CE).
-BLOCK indicates that end of lines should be marked with either CCE, CE or CS
-\(if CE is empty) and that those markers should be aligned.
-LINES indicates that an extra lines will be used at the beginning and end
-of the region for CE and CS.
-INDENT indicates to put CS and CCS at the current indentation of the region
-rather than at left margin."
+CS and CE are the comment start string and comment end string,
+respectively. CCS and CCE are the comment continuation strings
+for the start and end of lines, respectively (default to CS and CE).
+BLOCK indicates that end of lines should be marked with either CCE,
+CE or CS \(if CE is empty) and that those markers should be aligned.
+LINES indicates that an extra lines will be used at the beginning
+and end of the region for CE and CS.
+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)))))))
@@ -955,7 +955,7 @@ rather than at left margin."
(defun comment-region (beg end &optional arg)
"Comment or uncomment each line in the region.
With just \\[universal-argument] prefix arg, uncomment each line in region BEG .. END.
-Numeric prefix arg ARG means use ARG comment characters.
+Numeric prefix ARG means use ARG comment characters.
If ARG is negative, delete that many comment characters instead.
By default, comments start at the left margin, are terminated on each line,
even for syntax in which newline does not end the comment and blank lines
diff --git a/lisp/outline.el b/lisp/outline.el
index 59aeb233fdd..0f7d3b627b0 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -216,6 +216,9 @@ in the file it applies to."
(defvar outline-mode-hook nil
"*This hook is run when outline mode starts.")
+(defvar outline-blank-line nil
+ "*Non-nil means to leave unhidden blank line before heading.")
+
;;;###autoload
(define-derived-mode outline-mode text-mode "Outline"
"Set major mode for editing outlines with selective display.
@@ -349,7 +352,7 @@ at the end of the buffer."
(if (re-search-forward (concat "\n\\(?:" outline-regexp "\\)")
nil 'move)
(goto-char (match-beginning 0)))
- (if (and (bolp) (not (bobp)))
+ (if (and (bolp) (or outline-blank-line (eobp)) (not (bobp)))
(forward-char -1)))
(defun outline-next-heading ()
@@ -706,8 +709,8 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
"Hide the body directly following this heading."
(interactive)
(outline-back-to-heading)
- (outline-end-of-heading)
(save-excursion
+ (outline-end-of-heading)
(outline-flag-region (point) (progn (outline-next-preface) (point)) t)))
(defun show-entry ()
@@ -770,9 +773,10 @@ Show the heading too, if it is currently invisible."
(defun outline-show-heading ()
"Show the current heading and move to its end."
(outline-flag-region (- (point)
- (if (bobp) 0
- (if (eq (char-before (1- (point))) ?\n)
- 2 1)))
+ (if (bobp) 0
+ (if (and outline-blank-line
+ (eq (char-before (1- (point))) ?\n))
+ 2 1)))
(progn (outline-end-of-heading) (point))
nil))
@@ -841,9 +845,9 @@ Show the heading too, if it is currently invisible."
(progn
;; Go to end of line before heading
(forward-char -1)
- (if (bolp)
- ;; leave blank line before heading
- (forward-char -1))))))
+ (if (and outline-blank-line (bolp))
+ ;; leave blank line before heading
+ (forward-char -1))))))
(defun show-branches ()
"Show all subheadings of this heading, but not their bodies."
@@ -884,6 +888,8 @@ Default is enough to cause the following heading to appear."
With argument, move up ARG levels.
If INVISIBLE-OK is non-nil, also consider invisible lines."
(interactive "p")
+ (and (eq this-command 'outline-up-heading)
+ (or (eq last-command 'outline-up-heading) (push-mark)))
(outline-back-to-heading invisible-ok)
(let ((start-level (funcall outline-level)))
(if (eq start-level 1)
diff --git a/lisp/paren.el b/lisp/paren.el
index ab3efe10ba5..6c5f9dece99 100644
--- a/lisp/paren.el
+++ b/lisp/paren.el
@@ -91,6 +91,9 @@ otherwise)."
:group 'faces
:group 'paren-showing)
+(defvar show-paren-highlight-openparen t
+ "*Non-nil turns on openparen highlighting when matching forward.")
+
(defvar show-paren-idle-timer nil)
;;;###autoload
@@ -195,7 +198,7 @@ in `show-paren-style' after `show-paren-delay' seconds of Emacs idle time."
;; If matching forward, and the openparen is unbalanced,
;; highlight the paren at point to indicate misbalance.
;; Otherwise, turn off any such highlighting.
- (if (and (= dir 1) (integerp pos))
+ (if (and (not show-paren-highlight-openparen) (= dir 1) (integerp pos))
(when (and show-paren-overlay-1
(overlay-buffer show-paren-overlay-1))
(delete-overlay show-paren-overlay-1))
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index 213b68a4000..1260867f7c6 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -1,6 +1,6 @@
;;; pcomplete.el --- programmable completion
-;; Copyright (C) 1999, 2000, 2001, 2002 Free Sofware Foundation
+;; Copyright (C) 1999, 2000,01,02,03,04 Free Sofware Foundation
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: processes abbrev
@@ -505,7 +505,7 @@ See the documentation for `pcomplete-arg'."
(defsubst pcomplete-actual-arg (&optional index offset)
"Return the actual text representation of the last argument.
-This different from `pcomplete-arg', which returns the textual value
+This is different from `pcomplete-arg', which returns the textual value
that the last argument evaluated to. This function returns what the
user actually typed in."
(buffer-substring (pcomplete-begin index offset) (point)))
@@ -531,7 +531,7 @@ user actually typed in."
(throw 'pcompleted nil))))
(defun pcomplete-match-string (which &optional index offset)
- "Like `string-match', but on the current completion argument."
+ "Like `match-string', but on the current completion argument."
(let ((arg (pcomplete-arg (or index 1) offset)))
(if arg
(match-string which arg)
@@ -583,8 +583,8 @@ user actually typed in."
(defun pcomplete-comint-setup (completef-sym)
"Setup a comint buffer to use pcomplete.
COMPLETEF-SYM should be the symbol where the
-dynamic-complete-functions are kept. For comint mode itself, this is
-`comint-dynamic-complete-functions'."
+dynamic-complete-functions are kept. For comint mode itself,
+this is `comint-dynamic-complete-functions'."
(set (make-local-variable 'pcomplete-parse-arguments-function)
'pcomplete-parse-comint-arguments)
(make-local-variable completef-sym)
@@ -709,7 +709,7 @@ match (files not matching the REGEXP will be excluded).
If PREDICATE is non-nil, it will also be used to refine the match
\(files for which the PREDICATE returns nil will be excluded).
If no directory information can be extracted from the completed
-component, DEFAULT-DIRECTORY is used as the basis for completion."
+component, `default-directory' is used as the basis for completion."
(let* ((name (substitute-env-vars pcomplete-stub))
(default-directory (expand-file-name
(or (file-name-directory name)
@@ -809,11 +809,10 @@ component, DEFAULT-DIRECTORY is used as the basis for completion."
(defun pcomplete-opt (options &optional prefix no-ganging args-follow)
"Complete a set of OPTIONS, each beginning with PREFIX (?- by default).
PREFIX may be t, in which case no PREFIX character is necessary.
-If REQUIRED is non-nil, the options must be present.
-If NO-GANGING is non-nil, each option is separate. -xy is not allowed.
-If ARGS-FOLLOW is non-nil, then options which arguments which take may
-have the argument appear after a ganged set of options. This is how
-tar behaves, for example."
+If NO-GANGING is non-nil, each option is separate (-xy is not allowed).
+If ARGS-FOLLOW is non-nil, then options which take arguments may have
+the argument appear after a ganged set of options. This is how tar
+behaves, for example."
(if (and (= pcomplete-index pcomplete-last)
(string= (pcomplete-arg) "-"))
(let ((len (length options))
@@ -864,7 +863,7 @@ tar behaves, for example."
(setq index (1+ index))))))))
(defun pcomplete--here (&optional form stub paring form-only)
- "Complete aganst the current argument, if at the end.
+ "Complete against the current argument, if at the end.
See the documentation for `pcomplete-here'."
(if (< pcomplete-index pcomplete-last)
(progn
@@ -893,7 +892,7 @@ See the documentation for `pcomplete-here'."
(throw 'pcomplete-completions (eval form))))
(defmacro pcomplete-here (&optional form stub paring form-only)
- "Complete aganst the current argument, if at the end.
+ "Complete against the current argument, if at the end.
If completion is to be done here, evaluate FORM to generate the list
of strings which will be used for completion purposes. If STUB is a
string, use it as the completion stub instead of the default (which is
@@ -913,10 +912,11 @@ always for the sake of efficiency.
If PARING is nil, this argument will be pared against previous
arguments using the function `file-truename' to normalize them.
-PARING may be a function, in which case that function is for
-normalization. If PARING is the value t, the argument dealt with by
-this call will not participate in argument paring. If it the integer
-0, all previous arguments that have been seen will be cleared.
+PARING may be a function, in which case that function is used for
+normalization. If PARING is t, the argument dealt with by this
+call will not participate in argument paring. If it is the
+integer 0, all previous arguments that have been seen will be
+cleared.
If FORM-ONLY is non-nil, only the result of FORM will be used to
generate the completions list. This means that the hook
@@ -1129,10 +1129,7 @@ See also `pcomplete-filename'."
(defun pcomplete--help ()
"Produce context-sensitive help for the current argument.
-If specific documentation can't be given, be generic.
-INFODOC specifies the Info node to goto. DOCUMENTATION is a sexp
-which will produce documentation for the argument (it is responsible
-for displaying in its own buffer)."
+If specific documentation can't be given, be generic."
(if (and pcomplete-help
(or (and (stringp pcomplete-help)
(fboundp 'Info-goto-node))
@@ -1150,12 +1147,6 @@ for displaying in its own buffer)."
;; general utilities
-(defsubst pcomplete-time-less-p (t1 t2)
- "Say whether time T1 is less than time T2."
- (or (< (car t1) (car t2))
- (and (= (car t1) (car t2))
- (< (nth 1 t1) (nth 1 t2)))))
-
(defun pcomplete-pare-list (l r &optional pred)
"Destructively remove from list L all elements matching any in list R.
Test is done using `equal'.
diff --git a/lisp/pcvs-defs.el b/lisp/pcvs-defs.el
index dadb194abb9..6fea0052a7d 100644
--- a/lisp/pcvs-defs.el
+++ b/lisp/pcvs-defs.el
@@ -305,6 +305,7 @@ This variable is buffer local and only used in the *cvs* buffer.")
("d" "diff" . cvs-mode-diff)
("b" "backup" . cvs-mode-diff-backup)
("h" "head" . cvs-mode-diff-head)
+ ("y" "yesterday" . cvs-mode-diff-yesterday)
("v" "vendor" . cvs-mode-diff-vendor))
"Keymap for diff-related operations in `cvs-mode'."
:name "Diff")
diff --git a/lisp/pcvs-util.el b/lisp/pcvs-util.el
index 86fafea37ea..3380077c74a 100644
--- a/lisp/pcvs-util.el
+++ b/lisp/pcvs-util.el
@@ -1,6 +1,6 @@
;;; pcvs-util.el --- utility functions for PCL-CVS -*- byte-compile-dynamic: t -*-
-;; Copyright (C) 1991,92,93,94,95,96,97,98,99,2000, 2001
+;; Copyright (C) 1991,92,93,94,95,96,97,98,99, 2000,01,04
;; Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@cs.yale.edu>
@@ -50,7 +50,6 @@
(dolist (x xs zs)
(unless (member x ys) (push x zs)))))
-
(defun cvs-map (-cvs-map-f &rest -cvs-map-ls)
(unless (cvs-every 'null -cvs-map-ls)
(cons (apply -cvs-map-f (mapcar 'car -cvs-map-ls))
@@ -77,22 +76,6 @@ the other elements. The ordering among elements is maintained."
(if (funcall p x) (push x car) (push x cdr)))
(cons (nreverse car) (nreverse cdr))))
-;; Copied from CL ;-(
-
-(defun cvs-butlast (x &optional n)
- "Returns a copy of LIST with the last N elements removed."
- (if (and n (<= n 0)) x
- (cvs-nbutlast (copy-sequence x) n)))
-
-(defun cvs-nbutlast (x &optional n)
- "Modifies LIST to remove the last N elements."
- (let ((m (length x)))
- (or n (setq n 1))
- (and (< n m)
- (progn
- (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
- x))))
-
;;;
;;; frame, window, buffer handling
;;;
diff --git a/lisp/pcvs.el b/lisp/pcvs.el
index 21e34fbc7ed..73f7106d0e8 100644
--- a/lisp/pcvs.el
+++ b/lisp/pcvs.el
@@ -764,7 +764,7 @@ before calling the real function `" (symbol-name fun-1) "'.\n")
(interactive)
(cvs-mode! ',fun-1)))))
- (t (error "unknown style %s in `defun-cvs-mode'" style)))))
+ (t (error "Unknown style %s in `defun-cvs-mode'" style)))))
(defun-cvs-mode cvs-mode-kill-process ()
"Kill the temporary buffer and associated process."
@@ -1312,10 +1312,7 @@ If there are any marked tins, and IGNORE-MARKS is nil, return them.
Otherwise, if the cursor selects a directory, and IGNORE-CONTENTS is
nil, return all files in it, else return just the directory.
Otherwise return (a list containing) the file the cursor points to, or
-an empty list if it doesn't point to a file at all.
-
-Args: &optional IGNORE-MARKS IGNORE-CONTENTS."
-
+an empty list if it doesn't point to a file at all."
(let ((fis nil))
(dolist (fi (if (and (boundp 'cvs-minor-current-files)
(consp cvs-minor-current-files))
@@ -1568,6 +1565,12 @@ See ``cvs-mode-diff'' for more info."
(interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
(cvs-mode-diff-1 (cons "-rHEAD" flags)))
+(defun-cvs-mode (cvs-mode-diff-yesterday . SIMPLE) (flags)
+ "Diff the selected files against yesterday's head of the current branch.
+See ``cvs-mode-diff'' for more info."
+ (interactive (list (cvs-flags-query 'cvs-diff-flags "cvs diff flags")))
+ (cvs-mode-diff-1 (cons "-Dyesterday" flags)))
+
(defun-cvs-mode (cvs-mode-diff-vendor . SIMPLE) (flags)
"Diff the selected files against the head of the vendor branch.
See ``cvs-mode-diff'' for more info."
@@ -1754,7 +1757,7 @@ Signal an error if there is no backup file."
(defun cvs-is-within-p (fis dir)
- "Non-nil is buffer is inside one of FIS (in DIR)."
+ "Non-nil if buffer is inside one of FIS (in DIR)."
(when (stringp buffer-file-name)
(setq buffer-file-name (expand-file-name buffer-file-name))
(let (ret)
@@ -1774,7 +1777,7 @@ BUF is the buffer to be used for cvs' output.
DONT-CHANGE-DISC non-nil indicates that the command will not change the
contents of files. This is only used by the parser.
POSTPROC is a list of expressions to be evaluated at the very end (after
- parsing if applicable). It will be prepended with `progn' is necessary."
+ parsing if applicable). It will be prepended with `progn' if necessary."
(let ((def-dir default-directory))
;; Save the relevant buffers
(save-some-buffers nil (lambda () (cvs-is-within-p fis def-dir))))
diff --git a/lisp/progmodes/ada-mode.el b/lisp/progmodes/ada-mode.el
index abc8db6d2c3..f7688e24069 100644
--- a/lisp/progmodes/ada-mode.el
+++ b/lisp/progmodes/ada-mode.el
@@ -1466,8 +1466,8 @@ The standard casing rules will no longer apply to this word."
;; If the word is already in the list, even with a different casing
;; we simply want to replace it.
(if (and (not (equal ada-case-exception '()))
- (assoc-ignore-case word ada-case-exception))
- (setcar (assoc-ignore-case word ada-case-exception) word)
+ (assoc-string word ada-case-exception t))
+ (setcar (assoc-string word ada-case-exception t) word)
(add-to-list 'ada-case-exception (cons word t))
)
@@ -1519,8 +1519,8 @@ word itself has a special casing."
;; If the word is already in the list, even with a different casing
;; we simply want to replace it.
(if (and (not (equal ada-case-exception-substring '()))
- (assoc-ignore-case word ada-case-exception-substring))
- (setcar (assoc-ignore-case word ada-case-exception-substring) word)
+ (assoc-string word ada-case-exception-substring t))
+ (setcar (assoc-string word ada-case-exception-substring t) word)
(add-to-list 'ada-case-exception-substring (cons word t))
)
@@ -1548,9 +1548,9 @@ word itself has a special casing."
(if (char-equal (string-to-char word) ?*)
(progn
(setq word (substring word 1))
- (unless (assoc-ignore-case word ada-case-exception-substring)
+ (unless (assoc-string word ada-case-exception-substring t)
(add-to-list 'ada-case-exception-substring (cons word t))))
- (unless (assoc-ignore-case word ada-case-exception)
+ (unless (assoc-string word ada-case-exception t)
(add-to-list 'ada-case-exception (cons word t)))))
(forward-line 1))
@@ -1618,8 +1618,8 @@ the exceptions defined in `ada-case-exception-file'."
(point)))
match)
;; If we have an exception, replace the word by the correct casing
- (if (setq match (assoc-ignore-case (buffer-substring start end)
- ada-case-exception))
+ (if (setq match (assoc-string (buffer-substring start end)
+ ada-case-exception t))
(progn
(delete-region start end)
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el
index c6f60d3dcc0..a61369004e8 100644
--- a/lisp/progmodes/cc-cmds.el
+++ b/lisp/progmodes/cc-cmds.el
@@ -1488,7 +1488,7 @@ more \"DWIM:ey\"."
(save-excursion
(beginning-of-line)
(or (not (re-search-backward
- sentence-end
+ (sentence-end)
(c-point 'bopl)
t))
(< (match-end 0)
diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el
index 62633fe2940..16064586ee9 100644
--- a/lisp/progmodes/cfengine.el
+++ b/lisp/progmodes/cfengine.el
@@ -1,6 +1,6 @@
;;; cfengine.el --- mode for editing Cfengine files
-;; Copyright (C) 2003 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
;; Keywords: languages
@@ -102,7 +102,8 @@ This includes those for cfservd as well as cfagent."))
(defun cfengine-beginning-of-defun ()
"`beginning-of-defun' function for Cfengine mode.
Treats actions as defuns."
- (end-of-line)
+ (unless (<= (current-column) (current-indentation))
+ (end-of-line))
(if (re-search-backward "^[[:alpha:]]+: *$" nil t)
(beginning-of-line)
(goto-char (point-min)))
@@ -113,7 +114,7 @@ Treats actions as defuns."
Treats actions as defuns."
(end-of-line)
(if (re-search-forward "^[[:alpha:]]+: *$" nil t)
- (progn (forward-line -1) (end-of-line))
+ (beginning-of-line)
(goto-char (point-max)))
t)
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index ff4256192c4..033ce883e5f 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -100,7 +100,7 @@ in the compilation output, and should return a transformed file name.")
;;;###autoload
(defvar compilation-process-setup-function nil
"*Function to call to customize the compilation process.
-This functions is called immediately before the compilation process is
+This function is called immediately before the compilation process is
started. It can be used to set any variables or functions that are used
while processing the output of the compilation process. The function
is called with variables `compilation-buffer' and `compilation-window'
@@ -125,11 +125,6 @@ describing how the process finished.")
Each function is called with two arguments: the compilation buffer,
and a string describing how the process finished.")
-(defvar compilation-last-buffer nil
- "The most recent compilation buffer.
-A buffer becomes most recent when its compilation is started
-or when it is used with \\[next-error] or \\[compile-goto-error].")
-
(defvar compilation-in-progress nil
"List of compilation processes now running.")
(or (assq 'compilation-in-progress minor-mode-alist)
@@ -176,8 +171,15 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
"^\"\\([^,\" \n\t]+\\)\", line \\([0-9]+\\)\
\\(?:[(. pos]+\\([0-9]+\\))?\\)?[:.,; (-]\\( warning:\\|[-0-9 ]*(W)\\)?" 1 2 3 (4))
+ (edg-1
+ "^\\([^ \n]+\\)(\\([0-9]+\\)): \\(?:error\\|warnin\\(g\\)\\|remar\\(k\\)\\)"
+ 1 2 nil (3 . 4))
+ (edg-2
+ "at line \\([0-9]+\\) of \"\\([^ \n]+\\)\"$"
+ 2 1 nil 0)
+
(epc
- "^Error [0-9]+ at (\\([0-9]*\\):\\([^)\n]+\\))" 2 1)
+ "^Error [0-9]+ at (\\([0-9]+\\):\\([^)\n]+\\))" 2 1)
(iar
"^\"\\(.*\\)\",\\([0-9]+\\)\\s-+\\(?:Error\\|Warnin\\(g\\)\\)\\[[0-9]+\\]:"
@@ -187,8 +189,9 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
"^\\([^( \n\t]+\\)(\\([0-9]+\\):\\([0-9]+\\)) :\
\\(?:warnin\\(g\\)\\|informationa\\(l\\)\\)?" 1 2 3 (4 . 5))
+ ;; fixme: should be `mips'
(irix
- "^[a-z0-9/]+: \\(?:[eE]rror\\|[wW]arnin\\(g\\)\\|[iI]nf\\(o\\)\\)[0-9 ]*:\
+ "^[-[:alnum:]_/]+: \\(?:[sS]evere\\|[eE]rror\\|[wW]arnin\\(g\\)\\|[iI]nf\\(o\\)\\)[0-9 ]*:\
\\([^,\" \n\t]+\\)\\(?:, line\\|:\\) \\([0-9]+\\):" 3 4 nil (1 . 2))
(java
@@ -206,8 +209,8 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
\\(.+\\):\\([0-9]+\\)\\(?:\\(:\\)\\|\\(,\\)\\)?" 1 2 nil (3 . 4))
(gnu
- "^\\(?:[a-zA-Z][-a-zA-Z0-9.]+: ?\\)?\
-\\([/.]*[a-zA-Z]:?[^ \t\n:]*\\): ?\
+ "^\\(?:[[:alpha:]][-[:alnum:].]+: ?\\)?\
+\\([/.]*[a-zA-Z]:?[^ \t\n:]*\\|{standard input}\\): ?\
\\([0-9]+\\)\\([.:]?\\)\\([0-9]+\\)?\
\\(?:-\\(?:\\([0-9]+\\)\\3\\)?\\.?\\([0-9]+\\)?\\)?:\
\\(?: *\\(\\(?:Future\\|Runtime\\)?[Ww]arning\\|W:\\)\\|\
@@ -228,6 +231,7 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
(1 (compilation-error-properties 2 3 nil nil nil 0 nil)
append)))
+ ;; Should be lint-1, lint-2 (SysV lint)
(mips-1
" (\\([0-9]+\\)) in \\([^ \n]+\\)" 2 1)
(mips-2
@@ -238,7 +242,9 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
: \\(?:error\\|warnin\\(g\\)\\) C[0-9]+:" 1 2 nil (3))
(oracle
- "^Semantic error at line \\([0-9]+\\), column \\([0-9]+\\), file \\(.*\\):$"
+ "^\\(?:Semantic error\\|Error\\|PCC-[0-9]+:\\).* line \\([0-9]+\\)\
+\\(?:\\(?:,\\| at\\)? column \\([0-9]+\\)\\)?\
+\\(?:,\\| in\\| of\\)? file \\(.*?\\):?$"
3 1 2)
(perl
@@ -261,16 +267,13 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1))
nil 1 nil (3) nil (2 (compilation-face '(3))))
(sun
- ": \\(?:ERROR\\|WARNIN\\(G\\)\\|REMAR\\(K\\)\\) \\(?:[a-zA-Z0-9 ]+, \\)?\
+ ": \\(?:ERROR\\|WARNIN\\(G\\)\\|REMAR\\(K\\)\\) \\(?:[[:alnum:] ]+, \\)?\
File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
3 4 5 (1 . 2))
(sun-ada
"^\\([^, \n\t]+\\), line \\([0-9]+\\), char \\([0-9]+\\)[:., \(-]" 1 2 3)
- (ultrix
- "^\\(?:cfe\\|fort\\): \\(Warning\\)?[^:\n]*: \\([^ \n]*\\), line \\([0-9]+\\):" 2 3 nil (1))
-
(4bsd
"\\(?:^\\|:: \\|\\S ( \\)\\(/[^ \n\t()]+\\)(\\([0-9]+\\))\
\\(?:: \\(warning:\\)?\\|$\\| ),\\)" 1 2 nil (3)))
@@ -279,14 +282,14 @@ File = \\(.+\\), Line = \\([0-9]+\\)\\(?:, Column = \\([0-9]+\\)\\)?"
(defcustom compilation-error-regexp-alist
(mapcar 'car compilation-error-regexp-alist-alist)
"Alist that specifies how to match errors in compiler output.
-Note that on Unix exerything is a valid filename, so these
+Note that on Unix everything is a valid filename, so these
matchers must make some common sense assumptions, which catch
normal cases. A shorter list will be lighter on resource usage.
Instead of an alist element, you can use a symbol, which is
looked up in `compilation-error-regexp-alist-alist'. You can see
the predefined symbols and their effects in the file
-`etc/compilation.txt' (linked below if your are customizing this).
+`etc/compilation.txt' (linked below if you are customizing this).
Each elt has the form (REGEXP FILE [LINE COLUMN TYPE HYPERLINK
HIGHLIGHT...]). If REGEXP matches, the FILE'th subexpression
@@ -328,7 +331,7 @@ be added."
(list 'const (car elt)))
compilation-error-regexp-alist-alist))
:link `(file-link :tag "example file"
- ,(concat doc-directory "compilation.txt"))
+ ,(expand-file-name "compilation.txt" data-directory))
:group 'compilation)
(defvar compilation-directory nil
@@ -357,7 +360,7 @@ you may also want to change `compilation-page-delimiter'.")
(1 font-lock-variable-name-face)
(2 (compilation-face '(4 . 3))))
;; Command output lines. Recognize `make[n]:' lines too.
- ("^\\([A-Za-z_0-9/.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:"
+ ("^\\([[:alnum:]_/.+-]+\\)\\(\\[\\([0-9]+\\)\\]\\)?[ \t]*:"
(1 font-lock-function-name-face) (3 compilation-line-face nil t))
(" --?o\\(?:utfile\\|utput\\)?[= ]?\\(\\S +\\)" . 1)
("^Compilation finished" . compilation-info-face)
@@ -427,7 +430,7 @@ You might also use mode hooks to specify it in certain modes, like this:
(defvar compilation-locs ())
(defvar compilation-debug nil
- "*Set this to `t' before creating a *compilation* buffer.
+ "*Set this to t before creating a *compilation* buffer.
Then every error line will have a debug text property with the matcher that
fit this line and the match data. Use `describe-text-properties'.")
@@ -447,17 +450,19 @@ starting the compilation process.")
(defvar compile-history nil)
(defface compilation-warning-face
- '((((type tty) (class color)) (:foreground "cyan" :weight bold))
- (((class color)) (:foreground "Orange" :weight bold))
+ '((((class color) (min-colors 16)) (:foreground "Orange" :weight bold))
+ (((class color)) (:foreground "cyan" :weight bold))
(t (:weight bold)))
"Face used to highlight compiler warnings."
:group 'font-lock-highlighting-faces
:version "21.4")
(defface compilation-info-face
- '((((type tty) (class color)) (:foreground "green" :weight bold))
- (((class color) (background light)) (:foreground "Green3" :weight bold))
- (((class color) (background dark)) (:foreground "Green" :weight bold))
+ '((((class color) (min-colors 16) (background light))
+ (:foreground "Green3" :weight bold))
+ (((class color) (min-colors 16) (background dark))
+ (:foreground "Green" :weight bold))
+ (((class color)) (:foreground "green" :weight bold))
(t (:weight bold)))
"Face used to highlight compiler warnings."
:group 'font-lock-highlighting-faces
@@ -494,7 +499,8 @@ Faces `compilation-error-face', `compilation-warning-face',
;; Used for compatibility with the old compile.el.
-(defvar compilation-parsing-end nil)
+(defvaralias 'compilation-last-buffer 'next-error-last-buffer)
+(defvar compilation-parsing-end (make-marker))
(defvar compilation-parse-errors-function nil)
(defvar compilation-error-list nil)
(defvar compilation-old-error-list nil)
@@ -518,6 +524,7 @@ Faces `compilation-error-face', `compilation-warning-face',
'(nil)) ; nil only isn't a property-change
(cons (match-string-no-properties idx) dir))
mouse-face highlight
+ keymap compilation-button-map
help-echo "mouse-2: visit current directory")))
;; Data type `reverse-ordered-alist' retriever. This function retrieves the
@@ -528,6 +535,7 @@ Faces `compilation-error-face', `compilation-warning-face',
;; may be nil. The other KEYs are ordered backwards so that growing line
;; numbers can be inserted in front and searching can abort after half the
;; list on average.
+(eval-when-compile ;Don't keep it at runtime if not needed.
(defmacro compilation-assq (key alist)
`(let* ((l1 ,alist)
(l2 (cdr l1)))
@@ -538,7 +546,7 @@ Faces `compilation-error-face', `compilation-warning-face',
l2 (cdr l1)))
(if l2 (eq ,key (caar l2))))
l2
- (setcdr l1 (cons (list ,key) l2))))))
+ (setcdr l1 (cons (list ,key) l2)))))))
;; This function is the central driver, called when font-locking to gather
@@ -556,17 +564,13 @@ Faces `compilation-error-face', `compilation-warning-face',
(setq dir (previous-single-property-change (point) 'directory)
dir (if dir (or (get-text-property (1- dir) 'directory)
(get-text-property dir 'directory)))))
- (setq file (cons file (car dir)) ; top of dir stack is current
- file (or (gethash file compilation-locs)
- (puthash file (list file fmt) compilation-locs)))))
+ (setq file (cons file (car dir)))))
;; This message didn't mention one, get it from previous
(setq file (previous-single-property-change (point) 'message)
file (or (if file
- (nth 2 (car (or (get-text-property (1- file) 'message)
- (get-text-property file 'message)))))
- ;; no previous either -- let font-lock continue
- (gethash (setq file '("*unknown*")) compilation-locs)
- (puthash file (list file fmt) compilation-locs))))
+ (car (nth 2 (car (or (get-text-property (1- file) 'message)
+ (get-text-property file 'message))))))
+ '("*unknown*"))))
;; All of these fields are optional, get them only if we have an index, and
;; it matched some part of the message.
(and line
@@ -579,75 +583,87 @@ Faces `compilation-error-face', `compilation-warning-face',
(setq col (match-string-no-properties col))
(setq col (- (string-to-number col) compilation-first-column)))
(if (and end-col (setq end-col (match-string-no-properties end-col)))
- (setq end-col (- (string-to-number end-col) compilation-first-column))
+ (setq end-col (- (string-to-number end-col) compilation-first-column -1))
(if end-line (setq end-col -1)))
- (if (consp type) ; not a preset type, check what it is.
+ (if (consp type) ; not a static type, check what it is.
(setq type (or (and (car type) (match-end (car type)) 1)
(and (cdr type) (match-end (cdr type)) 0)
2)))
- ;; Get any (first) already existing marker (if any has one, all have one).
- ;; Do this first, as the next assq`s may create new nodes.
- (let ((marker (nth 3 (car (cdar (cddr file)))))
- (loc (compilation-assq line (cdr file)))
- end-loc)
- (if end-line
- (setq end-loc (compilation-assq end-line (cdr file))
- end-loc (compilation-assq end-col end-loc))
- (if end-col ; use same line element
- (setq end-loc (compilation-assq end-col loc))))
- (setq loc (compilation-assq col loc))
- ;; If they are new, make the loc(s) reference the file they point to.
- (or (cdr loc) (setcdr loc (list line file)))
- (if end-loc
- (or (cdr end-loc) (setcdr end-loc (list (or end-line line) file))))
- ;; If we'd found a marker, ensure that the new locs also get markers
- (when (and marker
- (not (or (cddr loc) (cddr end-loc))) ; maybe new node w/o marker
- (marker-buffer marker)) ; other marker still valid
- (or line (setq line 1)) ; normalize no linenumber to line 1
- (catch 'marker ; find nearest loc, at least one exists
- (dolist (x (cddr file))
- (if (> (or (car x) 1) line)
- (setq marker x)
- (if (eq (or (car x) 1) line)
- (if (cdr (cddr x)) ; at least one other column
- (throw 'marker (setq marker x))
- (if marker (throw 'marker t)))
- (throw 'marker (or marker (setq marker x)))))))
- (setq marker (if (eq (car (cddr marker)) col)
- (nthcdr 3 marker)
- (cddr marker))
- file compilation-error-screen-columns)
- (with-current-buffer (marker-buffer (cddr marker))
- (save-restriction
- (widen)
- (goto-char (marker-position (cddr marker)))
- (beginning-of-line (- line (car (cadr marker)) -1))
- (if file ; original c.-error-screen-columns
- (move-to-column (car loc))
- (forward-char (car loc)))
- (setcdr (cdr loc) (point-marker))
- (when end-loc
- (beginning-of-line (- end-line line -1))
- (if (< end-col 0)
- (end-of-line)
- (if file ; original c.-error-screen-columns
- (move-to-column (car end-loc))
- (forward-char (car end-loc))))
- (setcdr (cdr end-loc) (point-marker))))))
- ;; Must start with face
- `(face ,compilation-message-face
- message (,loc ,type ,end-loc)
- ,@(if compilation-debug
- `(debug (,(assoc (with-no-warnings matcher) font-lock-keywords)
- ,@(match-data))))
- help-echo ,(if col
- "mouse-2: visit this file, line and column"
- (if line
- "mouse-2: visit this file and line"
- "mouse-2: visit this file"))
- keymap compilation-button-map
- mouse-face highlight))))
+ (compilation-internal-error-properties file line end-line col end-col type fmt)))
+
+(defun compilation-internal-error-properties (file line end-line col end-col type fmt)
+ "Get the meta-info that will be added as text-properties.
+LINE, END-LINE, COL, END-COL are integers or nil.
+TYPE can be 0, 1, or 2.
+FILE should be (ABSOLUTE-FILENAME) or (RELATIVE-FILENAME . DIRNAME) or nil."
+ (unless file (setq file '("*unknown*")))
+ (setq file (compilation-get-file-structure file fmt))
+ ;; Get first already existing marker (if any has one, all have one).
+ ;; Do this first, as the compilation-assq`s may create new nodes.
+ (let* ((marker-line (car (cddr file))) ; a line structure
+ (marker (nth 3 (cadr marker-line))) ; its marker
+ (compilation-error-screen-columns compilation-error-screen-columns)
+ end-marker loc end-loc)
+ (if (not (and marker (marker-buffer marker)))
+ (setq marker) ; no valid marker for this file
+ (setq loc (or line 1)) ; normalize no linenumber to line 1
+ (catch 'marker ; find nearest loc, at least one exists
+ (dolist (x (nthcdr 3 file)) ; loop over remaining lines
+ (if (> (car x) loc) ; still bigger
+ (setq marker-line x)
+ (if (> (- (or (car marker-line) 1) loc)
+ (- loc (car x))) ; current line is nearer
+ (setq marker-line x))
+ (throw 'marker t))))
+ (setq marker (nth 3 (cadr marker-line))
+ marker-line (or (car marker-line) 1))
+ (with-current-buffer (marker-buffer marker)
+ (save-restriction
+ (widen)
+ (goto-char (marker-position marker))
+ (when (or end-col end-line)
+ (beginning-of-line (- (or end-line line) marker-line -1))
+ (if (< end-col 0)
+ (end-of-line)
+ (if compilation-error-screen-columns
+ (move-to-column end-col)
+ (forward-char end-col)))
+ (setq end-marker (list (point-marker))))
+ (beginning-of-line (if end-line
+ (- end-line line -1)
+ (- loc marker-line -1)))
+ (if col
+ (if compilation-error-screen-columns
+ (move-to-column col)
+ (forward-char col))
+ (forward-to-indentation 0))
+ (setq marker (list (point-marker))))))
+
+ (setq loc (compilation-assq line (cdr file)))
+ (if end-line
+ (setq end-loc (compilation-assq end-line (cdr file))
+ end-loc (compilation-assq end-col end-loc))
+ (if end-col ; use same line element
+ (setq end-loc (compilation-assq end-col loc))))
+ (setq loc (compilation-assq col loc))
+ ;; If they are new, make the loc(s) reference the file they point to.
+ (or (cdr loc) (setcdr loc `(,line ,file ,@marker)))
+ (if end-loc
+ (or (cdr end-loc) (setcdr end-loc `(,(or end-line line) ,file ,@end-marker))))
+
+ ;; Must start with face
+ `(face ,compilation-message-face
+ message (,loc ,type ,end-loc)
+ ,@(if compilation-debug
+ `(debug (,(assoc (with-no-warnings matcher) font-lock-keywords)
+ ,@(match-data))))
+ help-echo ,(if col
+ "mouse-2: visit this file, line and column"
+ (if line
+ "mouse-2: visit this file and line"
+ "mouse-2: visit this file"))
+ keymap compilation-button-map
+ mouse-face highlight)))
(defun compilation-mode-font-lock-keywords ()
"Return expressions to highlight in Compilation mode."
@@ -686,12 +702,15 @@ Faces `compilation-error-face', `compilation-warning-face',
;; error location. Let's do our best.
`(,(car item)
(0 (compilation-compat-error-properties
- (funcall ',line (list* (match-string ,file)
- default-directory
- ',(nthcdr 4 item))
+ (funcall ',line (cons (match-string ,file)
+ (cons default-directory
+ ',(nthcdr 4 item)))
,(if col `(match-string ,col)))))
(,file compilation-error-face t))
+ (unless (or (null (nth 5 item)) (integerp (nth 5 item)))
+ (error "HYPERLINK should be an integer: %s" (nth 5 item)))
+
`(,(nth 0 item)
,@(when (integerp file)
@@ -729,7 +748,7 @@ Faces `compilation-error-face', `compilation-warning-face',
Runs COMMAND, a shell command, in a separate process asynchronously
with output going to the buffer `*compilation*'.
-If optional second arg COMINT is t the buffer will be in comint mode with
+If optional second arg COMINT is t the buffer will be in Comint mode with
`compilation-shell-minor-mode'.
You can then use the command \\[next-error] to find the next error message
@@ -737,6 +756,8 @@ and move to the source code that caused it.
Interactively, prompts for the command if `compilation-read-command' is
non-nil; otherwise uses `compile-command'. With prefix arg, always prompts.
+Additionally, with universal prefix arg, compilation buffer will be in
+comint mode, i.e. interactive.
To run more than one compilation at once, start one and rename
the \`*compilation*' buffer to some other name with
@@ -748,11 +769,13 @@ The name used for the buffer is actually whatever is returned by
the function in `compilation-buffer-name-function', so you can set that
to a function that generates a unique name."
(interactive
- (if (or compilation-read-command current-prefix-arg)
- (list (read-from-minibuffer "Compile command: "
- (eval compile-command) nil nil
- '(compile-history . 1)))
- (list (eval compile-command))))
+ (list
+ (if (or compilation-read-command current-prefix-arg)
+ (read-from-minibuffer "Compile command: "
+ (eval compile-command) nil nil
+ '(compile-history . 1))
+ (eval compile-command))
+ (consp current-prefix-arg)))
(unless (equal command (eval compile-command))
(setq compile-command command))
(save-some-buffers (not compilation-ask-about-save) nil)
@@ -762,8 +785,8 @@ to a function that generates a unique name."
;; run compile with the default command line
(defun recompile ()
"Re-compile the program including the current buffer.
-If this is run in a compilation-mode buffer, re-use the arguments from the
-original use. Otherwise, it recompiles using `compile-command'."
+If this is run in a Compilation mode buffer, re-use the arguments from the
+original use. Otherwise, recompile using `compile-command'."
(interactive)
(save-some-buffers (not compilation-ask-about-save) nil)
(let ((default-directory (or compilation-directory default-directory)))
@@ -773,9 +796,9 @@ original use. Otherwise, it recompiles using `compile-command'."
(defcustom compilation-scroll-output nil
"*Non-nil to scroll the *compilation* buffer window as output appears.
-Setting it causes the compilation-mode commands to put point at the
+Setting it causes the Compilation mode commands to put point at the
end of their output window so that the end of the output is always
-visible rather than the begining."
+visible rather than the beginning."
:type 'boolean
:version "20.3"
:group 'compilation)
@@ -822,11 +845,11 @@ Otherwise, construct a buffer name from MODE-NAME."
The rest of the arguments are optional; for them, nil means use the default.
MODE is the major mode to set in the compilation buffer. Mode
-may also be `t' meaning `compilation-shell-minor-mode' under `comint-mode'.
+may also be t meaning use `compilation-shell-minor-mode' under `comint-mode'.
NAME-FUNCTION is a function called to name the buffer.
If HIGHLIGHT-REGEXP is non-nil, `next-error' will temporarily highlight
-matching section of the visited source line; the default is to use the
+the matching section of the visited source line; the default is to use the
global value of `compilation-highlight-regexp'.
Returns the compilation buffer created."
@@ -838,8 +861,8 @@ Returns the compilation buffer created."
(process-environment
(append
compilation-environment
- (if (and (boundp 'system-uses-terminfo)
- system-uses-terminfo)
+ (if (if (boundp 'system-uses-terminfo) ; `if' for compiler warning
+ system-uses-terminfo)
(list "TERM=dumb" "TERMCAP="
(format "COLUMNS=%d" (window-width)))
(list "TERM=emacs"
@@ -903,7 +926,9 @@ Returns the compilation buffer created."
'compilation-revert-buffer)
(set-window-start outwin (point-min))
(or (eq outwin (selected-window))
- (set-window-point outwin (point)))
+ (set-window-point outwin (if compilation-scroll-output
+ (point)
+ (point-min))))
;; The setup function is called before compilation-set-window-height
;; so it can set the compilation-window-height buffer locally.
(if compilation-process-setup-function
@@ -930,6 +955,7 @@ Returns the compilation buffer created."
;; Fake modeline display as if `start-process' were run.
(setq mode-line-process ":run")
(force-mode-line-update)
+ (sit-for 0) ; Force redisplay
(let ((status (call-process shell-file-name nil outbuf nil "-c"
command)))
(cond ((numberp status)
@@ -944,13 +970,17 @@ exited abnormally with code %d\n"
(concat status "\n")))
(t
(compilation-handle-exit 'bizarre status status))))
+ ;; Without async subprocesses, the buffer is not yet
+ ;; fontified, so fontify it now.
+ (let ((font-lock-verbose nil)) ; shut up font-lock messages
+ (font-lock-fontify-buffer))
(message "Executing `%s'...done" command)))
(if (buffer-local-value 'compilation-scroll-output outbuf)
(save-selected-window
(select-window outwin)
(goto-char (point-max))))
;; Make it so the next C-x ` will use this buffer.
- (setq compilation-last-buffer outbuf)))
+ (setq next-error-last-buffer outbuf)))
(defun compilation-set-window-height (window)
"Set the height of WINDOW according to `compilation-window-height'."
@@ -960,9 +990,8 @@ exited abnormally with code %d\n"
;; If window is alone in its frame, aside from a minibuffer,
;; don't change its height.
(not (eq window (frame-root-window (window-frame window))))
- ;; This save-current-buffer prevents us from changing the current
- ;; buffer, which might not be the same as the selected window's buffer.
- (save-current-buffer
+ ;; Stef said that doing the saves in this order is safer:
+ (save-excursion
(save-selected-window
(select-window window)
(enlarge-window (- height (window-height))))))))
@@ -1132,20 +1161,30 @@ variable exists."
"Marker to the location from where the next error will be found.
The global commands next/previous/first-error/goto-error use this.")
+(defvar compilation-messages-start nil
+ "Buffer position of the beginning of the compilation messages.
+If nil, use the beginning of buffer.")
+
;; A function name can't be a hook, must be something with a value.
(defconst compilation-turn-on-font-lock 'turn-on-font-lock)
(defun compilation-setup (&optional minor)
- "Prepare the buffer for the compilation parsing commands to work."
+ "Prepare the buffer for the compilation parsing commands to work.
+Optional argument MINOR indicates this is called from
+`compilation-minor-mode'."
(make-local-variable 'compilation-current-error)
+ (make-local-variable 'compilation-messages-start)
(make-local-variable 'compilation-error-screen-columns)
(make-local-variable 'overlay-arrow-position)
- (setq compilation-last-buffer (current-buffer))
+ ;; Note that compilation-next-error-function is for interfacing
+ ;; with the next-error function in simple.el, and it's only
+ ;; coincidentally named similarly to compilation-next-error.
+ (setq next-error-function 'compilation-next-error-function)
(set (make-local-variable 'font-lock-extra-managed-props)
'(directory message help-echo mouse-face debug))
(set (make-local-variable 'compilation-locs)
(make-hash-table :test 'equal :weakness 'value))
- ;; lazy-lock would never find the message unless it's scrolled to
+ ;; lazy-lock would never find the message unless it's scrolled to.
;; jit-lock might fontify some things too late.
(set (make-local-variable 'font-lock-support-mode) nil)
(set (make-local-variable 'font-lock-maximum-size) nil)
@@ -1193,7 +1232,7 @@ Turning the mode on runs the normal hook `compilation-minor-mode-hook'."
(font-lock-fontify-buffer)))
(defun compilation-handle-exit (process-status exit-status msg)
- "Write msg in the current buffer and hack its mode-line-process."
+ "Write MSG in the current buffer and hack its mode-line-process."
(let ((buffer-read-only nil)
(status (if compilation-exit-message-function
(funcall compilation-exit-message-function
@@ -1257,8 +1296,16 @@ Just inserts the text, but uses `insert-before-markers'."
(insert-before-markers string)
(run-hooks 'compilation-filter-hook))))))
+;;; test if a buffer is a compilation buffer, assuming we're in the buffer
+(defsubst compilation-buffer-internal-p ()
+ "Test if inside a compilation buffer."
+ (local-variable-p 'compilation-locs))
+
+;;; test if a buffer is a compilation buffer, using compilation-buffer-internal-p
(defsubst compilation-buffer-p (buffer)
- (local-variable-p 'compilation-locs buffer))
+ "Test if BUFFER is a compilation buffer."
+ (with-current-buffer buffer
+ (compilation-buffer-internal-p)))
(defmacro compilation-loop (< property-change 1+ error)
`(while (,< n 0)
@@ -1289,7 +1336,6 @@ Does NOT find the source line like \\[next-error]."
(or (compilation-buffer-p (current-buffer))
(error "Not in a compilation buffer"))
(or pt (setq pt (point)))
- (setq compilation-last-buffer (current-buffer))
(let* ((msg (get-text-property pt 'message))
(loc (car msg))
last)
@@ -1327,25 +1373,6 @@ Does NOT find the source line like \\[previous-error]."
(interactive "p")
(compilation-next-error (- n)))
-(defun next-error-no-select (n)
- "Move point to the next error in the compilation buffer and highlight match.
-Prefix arg N says how many error messages to move forwards (or
-backwards, if negative).
-Finds and highlights the source line like \\[next-error], but does not
-select the source buffer."
- (interactive "p")
- (next-error n)
- (pop-to-buffer compilation-last-buffer))
-
-(defun previous-error-no-select (n)
- "Move point to the previous error in the compilation buffer and highlight match.
-Prefix arg N says how many error messages to move backwards (or
-forwards, if negative).
-Finds and highlights the source line like \\[previous-error], but does not
-select the source buffer."
- (interactive "p")
- (next-error-no-select (- n)))
-
(defun compilation-next-file (n)
"Move point to the next error for a different file than the current one.
Prefix arg N says how many files to move forwards (or backwards, if negative)."
@@ -1383,73 +1410,35 @@ Use this command in a compilation log buffer. Sets the mark at point there."
;; Return a compilation buffer.
;; If the current buffer is a compilation buffer, return it.
-;; If compilation-last-buffer is set to a live buffer, use that.
;; Otherwise, look for a compilation buffer and signal an error
;; if there are none.
(defun compilation-find-buffer (&optional other-buffer)
- (if (and (not other-buffer)
- (compilation-buffer-p (current-buffer)))
- ;; The current buffer is a compilation buffer.
- (current-buffer)
- (if (and compilation-last-buffer (buffer-name compilation-last-buffer)
- (compilation-buffer-p compilation-last-buffer)
- (or (not other-buffer) (not (eq compilation-last-buffer
- (current-buffer)))))
- compilation-last-buffer
- (let ((buffers (buffer-list)))
- (while (and buffers (or (not (compilation-buffer-p (car buffers)))
- (and other-buffer
- (eq (car buffers) (current-buffer)))))
- (setq buffers (cdr buffers)))
- (if buffers
- (car buffers)
- (or (and other-buffer
- (compilation-buffer-p (current-buffer))
- ;; The current buffer is a compilation buffer.
- (progn
- (if other-buffer
- (message "This is the only compilation buffer."))
- (current-buffer)))
- (error "No compilation started!")))))))
+ (next-error-find-buffer other-buffer 'compilation-buffer-internal-p))
;;;###autoload
-(defun next-error (&optional n)
- "Visit next compilation error message and corresponding source code.
-Prefix arg N says how many error messages to move forwards (or
-backwards, if negative).
-
-\\[next-error] normally uses the most recently started compilation or
-grep buffer. However, it can operate on any buffer with output from
-the \\[compile] and \\[grep] commands, or, more generally, on any
-buffer in Compilation mode or with Compilation Minor mode enabled. To
-specify use of a particular buffer for error messages, type
-\\[next-error] in that buffer.
-
-Once \\[next-error] has chosen the buffer for error messages,
-it stays with that buffer until you use it in some other buffer which
-uses Compilation mode or Compilation Minor mode.
-
-See variable `compilation-error-regexp-alist' for customization ideas."
+(defun compilation-next-error-function (n &optional reset)
(interactive "p")
- (set-buffer (setq compilation-last-buffer (compilation-find-buffer)))
+ (set-buffer (compilation-find-buffer))
+ (when reset
+ (setq compilation-current-error nil))
(let* ((columns compilation-error-screen-columns) ; buffer's local value
(last 1)
(loc (compilation-next-error (or n 1) nil
- (or compilation-current-error (point-min))))
+ (or compilation-current-error
+ compilation-messages-start
+ (point-min))))
(end-loc (nth 2 loc))
(marker (point-marker)))
(setq compilation-current-error (point-marker)
overlay-arrow-position
(if (bolp)
compilation-current-error
- (save-excursion
- (beginning-of-line)
- (point-marker)))
+ (copy-marker (line-beginning-position)))
loc (car loc))
;; If loc contains no marker, no error in that file has been visited. If
;; the marker is invalid the buffer has been killed. So, recalculate all
;; markers for that file.
- (unless (and (nthcdr 3 loc) (marker-buffer (nth 3 loc)))
+ (unless (and (nth 3 loc) (marker-buffer (nth 3 loc)))
(with-current-buffer (compilation-find-file marker (caar (nth 2 loc))
(or (cdar (nth 2 loc))
default-directory))
@@ -1472,50 +1461,66 @@ See variable `compilation-error-regexp-alist' for customization ideas."
(forward-char (car col))))
(beginning-of-line)
(skip-chars-forward " \t"))
- (if (nthcdr 3 col)
+ (if (nth 3 col)
(set-marker (nth 3 col) (point))
(setcdr (nthcdr 2 col) `(,(point-marker)))))))))
(compilation-goto-locus marker (nth 3 loc) (nth 3 end-loc))
(setcdr (nthcdr 3 loc) t))) ; Set this one as visited.
-;;;###autoload (define-key ctl-x-map "`" 'next-error)
-
-(defun previous-error (n)
- "Visit previous compilation error message and corresponding source code.
-Prefix arg N says how many error messages to move backwards (or
-forwards, if negative).
-
-This operates on the output from the \\[compile] and \\[grep] commands."
- (interactive "p")
- (next-error (- n)))
-
-(defun first-error (n)
- "Restart at the first error.
-Visit corresponding source code.
-With prefix arg N, visit the source code of the Nth error.
-This operates on the output from the \\[compile] command."
- (interactive "p")
- (set-buffer (setq compilation-last-buffer (compilation-find-buffer)))
- (setq compilation-current-error nil)
- (next-error n))
-
-(defcustom compilation-context-lines next-screen-context-lines
- "*Display this many lines of leading context before message."
- :type 'integer
+(defvar compilation-gcpro nil
+ "Internal variable used to keep some values from being GC'd.")
+(make-variable-buffer-local 'compilation-gcpro)
+
+(defun compilation-fake-loc (marker file &optional line col)
+ "Preassociate MARKER with FILE.
+FILE should be ABSOLUTE-FILENAME or (RELATIVE-FILENAME . DIRNAME).
+This is useful when you compile temporary files, but want
+automatic translation of the messages to the real buffer from
+which the temporary file came. This only works if done before a
+message about FILE appears!
+
+Optional args LINE and COL default to 1 and beginning of
+indentation respectively. The marker is expected to reflect
+this. In the simplest case the marker points to the first line
+of the region that was saved to the temp file.
+
+If you concatenate several regions into the temp file (e.g. a
+header with variable assignments and a code region), you must
+call this several times, once each for the last line of one
+region and the first line of the next region."
+ (or (consp file) (setq file (list file)))
+ (setq file (compilation-get-file-structure file))
+ ;; Between the current call to compilation-fake-loc and the first occurrence
+ ;; of an error message referring to `file', the data is only kept is the
+ ;; weak hash-table compilation-locs, so we need to prevent this entry
+ ;; in compilation-locs from being GC'd away. --Stef
+ (push file compilation-gcpro)
+ (let ((loc (compilation-assq (or line 1) (cdr file))))
+ (setq loc (compilation-assq col loc))
+ (if (cdr loc)
+ (setcdr (cddr loc) (list marker))
+ (setcdr loc (list line file marker)))
+ loc))
+
+(defcustom compilation-context-lines 0
+ "*Display this many lines of leading context before message.
+If nil, don't scroll the compilation output window."
+ :type '(choice integer (const :tag "No window scrolling" nil))
:group 'compilation
:version "21.4")
(defsubst compilation-set-window (w mk)
- ;; Align the compilation output window W with marker MK near top.
- (set-window-start w (save-excursion
- (goto-char mk)
- (beginning-of-line (- 1 compilation-context-lines))
- (point)))
+ "Align the compilation output window W with marker MK near top."
+ (if (integerp compilation-context-lines)
+ (set-window-start w (save-excursion
+ (goto-char mk)
+ (beginning-of-line (- 1 compilation-context-lines))
+ (point))))
(set-window-point w mk))
(defun compilation-goto-locus (msg mk end-mk)
- "Jump to an error MESSAGE and SOURCE.
-All arguments are markers. If SOURCE-END is non nil, mark is set there."
+ "Jump to an error corresponding to MSG at MK.
+All arguments are markers. If END-MK is non nil, mark is set there."
(if (eq (window-buffer (selected-window))
(marker-buffer msg))
;; If the compilation buffer window is selected,
@@ -1622,67 +1627,58 @@ Pop up the buffer containing MARKER and scroll to MARKER if we ask the user."
(overlays-in (point-min) (point-max)))
buffer)))
-(defun compilation-normalize-filename (filename)
- "Convert a filename string found in an error message to make it usable."
-
- ;; Check for a comint-file-name-prefix and prepend it if
- ;; appropriate. (This is very useful for
- ;; compilation-minor-mode in an rlogin-mode buffer.)
- (and (boundp 'comint-file-name-prefix)
- ;; If file name is relative, default-directory will
- ;; already contain the comint-file-name-prefix (done
- ;; by compile-abbreviate-directory).
- (file-name-absolute-p filename)
- (setq filename
- (concat (with-no-warnings 'comint-file-name-prefix) filename)))
-
- ;; If compilation-parse-errors-filename-function is
- ;; defined, use it to process the filename.
- (when compilation-parse-errors-filename-function
- (setq filename
- (funcall compilation-parse-errors-filename-function
- filename)))
-
- ;; Some compilers (e.g. Sun's java compiler, reportedly)
- ;; produce bogus file names like "./bar//foo.c" for file
- ;; "bar/foo.c"; expand-file-name will collapse these into
- ;; "/foo.c" and fail to find the appropriate file. So we
- ;; look for doubled slashes in the file name and fix them
- ;; up in the buffer.
- (setq filename (command-line-normalize-file-name filename)))
-
-
-;; If directory DIR is a subdir of ORIG or of ORIG's parent,
-;; return a relative name for it starting from ORIG or its parent.
-;; ORIG-EXPANDED is an expanded version of ORIG.
-;; PARENT-EXPANDED is an expanded version of ORIG's parent.
-;; Those two args could be computed here, but we run faster by
-;; having the caller compute them just once.
-(defun compile-abbreviate-directory (dir orig orig-expanded parent-expanded)
- ;; Apply canonical abbreviations to DIR first thing.
- ;; Those abbreviations are already done in the other arguments passed.
- (setq dir (abbreviate-file-name dir))
-
- ;; Check for a comint-file-name-prefix and prepend it if appropriate.
- ;; (This is very useful for compilation-minor-mode in an rlogin-mode
- ;; buffer.)
- (if (boundp 'comint-file-name-prefix)
- (setq dir (concat comint-file-name-prefix dir)))
-
- (if (and (> (length dir) (length orig-expanded))
- (string= orig-expanded
- (substring dir 0 (length orig-expanded))))
- (setq dir
- (concat orig
- (substring dir (length orig-expanded)))))
- (if (and (> (length dir) (length parent-expanded))
- (string= parent-expanded
- (substring dir 0 (length parent-expanded))))
- (setq dir
- (concat (file-name-directory
- (directory-file-name orig))
- (substring dir (length parent-expanded)))))
- dir)
+(defun compilation-get-file-structure (file &optional fmt)
+ "Retrieve FILE's file-structure or create a new one.
+FILE should be (ABSOLUTE-FILENAME) or (RELATIVE-FILENAME . DIRNAME)."
+
+ (or (gethash file compilation-locs)
+ ;; File was not previously encountered, at least not in the form passed.
+ ;; Let's normalize it and look again.
+ (let ((filename (car file))
+ (default-directory (if (cdr file)
+ (file-truename (cdr file))
+ default-directory)))
+
+ ;; Check for a comint-file-name-prefix and prepend it if appropriate.
+ ;; (This is very useful for compilation-minor-mode in an rlogin-mode
+ ;; buffer.)
+ (if (boundp 'comint-file-name-prefix)
+ (if (file-name-absolute-p filename)
+ (setq filename
+ (concat (with-no-warnings comint-file-name-prefix) filename))
+ (setq default-directory
+ (file-truename
+ (concat (with-no-warnings comint-file-name-prefix) default-directory)))))
+
+ ;; If compilation-parse-errors-filename-function is
+ ;; defined, use it to process the filename.
+ (when compilation-parse-errors-filename-function
+ (setq filename
+ (funcall compilation-parse-errors-filename-function
+ filename)))
+
+ ;; Some compilers (e.g. Sun's java compiler, reportedly) produce bogus
+ ;; file names like "./bar//foo.c" for file "bar/foo.c";
+ ;; expand-file-name will collapse these into "/foo.c" and fail to find
+ ;; the appropriate file. So we look for doubled slashes in the file
+ ;; name and fix them.
+ (setq filename (command-line-normalize-file-name filename))
+
+ ;; Now eliminate any "..", because find-file would get them wrong.
+ ;; Make relative and absolute filenames, with or without links, the
+ ;; same.
+ (setq filename
+ (list (abbreviate-file-name
+ (file-truename (if (cdr file)
+ (expand-file-name filename)
+ filename)))))
+
+ ;; Store it for the possibly unnormalized name
+ (puthash file
+ ;; Retrieve or create file-structure for normalized name
+ (or (gethash filename compilation-locs)
+ (puthash filename (list filename fmt) compilation-locs))
+ compilation-locs))))
(add-to-list 'debug-ignored-errors "^No more [-a-z ]+s yet$")
@@ -1691,17 +1687,26 @@ Pop up the buffer containing MARKER and scroll to MARKER if we ask the user."
(defun compile-buffer-substring (n) (if n (match-string n)))
(defun compilation-compat-error-properties (err)
- ;; Map old-style ERROR to new-style MESSAGE.
- (let* ((dst (cdr err))
- (loc (cond ((markerp dst) (list nil nil nil dst))
- ((consp dst)
- (list (nth 2 dst) (nth 1 dst)
- (cons (cdar dst) (caar dst)))))))
- ;; Must start with a face, for font-lock.
- `(face nil
- message ,(list loc 2)
- help-echo "mouse-2: visit the source location"
- mouse-face highlight)))
+ "Map old-style error ERR to new-style message."
+ ;; Old-style structure is (MARKER (FILE DIR) LINE COL) or
+ ;; (MARKER . MARKER).
+ (let ((dst (cdr err)))
+ (if (markerp dst)
+ ;; Must start with a face, for font-lock.
+ `(face nil
+ message ,(list (list nil nil nil dst) 2)
+ help-echo "mouse-2: visit the source location"
+ keymap compilation-button-map
+ mouse-face highlight)
+ ;; Too difficult to do it by hand: dispatch to the normal code.
+ (let* ((file (pop dst))
+ (line (pop dst))
+ (col (pop dst))
+ (filename (pop file))
+ (dirname (pop file))
+ (fmt (pop file)))
+ (compilation-internal-error-properties
+ (cons filename dirname) line nil col nil 2 fmt)))))
(defun compilation-compat-parse-errors (limit)
(when compilation-parse-errors-function
@@ -1739,10 +1744,12 @@ Pop up the buffer containing MARKER and scroll to MARKER if we ask the user."
(goto-char limit)
nil)
+;; Beware: this is not only compatiblity code. New code stil uses it. --Stef
(defun compilation-forget-errors ()
;; In case we hit the same file/line specs, we want to recompute a new
;; marker for them, so flush our cache.
(setq compilation-locs (make-hash-table :test 'equal :weakness 'value))
+ (setq compilation-gcpro nil)
;; FIXME: the old code reset the directory-stack, so maybe we should
;; put a `directory change' marker of some sort, but where? -stef
;;
@@ -1754,9 +1761,19 @@ Pop up the buffer containing MARKER and scroll to MARKER if we ask the user."
;; something equivalent to point-max. So we speculatively move
;; compilation-current-error to point-max (since the external package
;; won't know that it should do it). --stef
- (setq compilation-current-error (point-max)))
+ (setq compilation-current-error nil)
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (mark (if proc (process-mark proc)))
+ (pos (or mark (point-max))))
+ (setq compilation-messages-start
+ ;; In the future, ignore the text already present in the buffer.
+ ;; Since many process filter functions insert before markers,
+ ;; we need to put ours just before the insertion point rather
+ ;; than at the insertion point. If that's not possible, then
+ ;; don't use a marker. --Stef
+ (if (> pos (point-min)) (copy-marker (1- pos)) pos))))
(provide 'compile)
-;;; arch-tag: 12465727-7382-4f72-b234-79855a00dd8c
+;; arch-tag: 12465727-7382-4f72-b234-79855a00dd8c
;;; compile.el ends here
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index e13198fb240..c651e06b899 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -926,12 +926,9 @@ the faces: please specify bold, italic, underline, shadow and box.)
(defun cperl-putback-char (c) ; Emacs 19
(set 'unread-command-events (list c))) ; Avoid undefined warning
-(if (boundp 'unread-command-events)
- (if cperl-xemacs-p
- (defun cperl-putback-char (c) ; XEmacs >= 19.12
- (setq unread-command-events (list (eval '(character-to-event c))))))
- (defun cperl-putback-char (c) ; XEmacs <= 19.11
- (set 'unread-command-event (eval '(character-to-event c))))) ; Avoid warnings
+(if cperl-xemacs-p
+ (defun cperl-putback-char (c) ; XEmacs >= 19.12
+ (setq unread-command-events (list (eval '(character-to-event c))))))
(or (fboundp 'uncomment-region)
(defun uncomment-region (beg end)
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index ef5d1eba998..184077f6a3a 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1248,7 +1248,11 @@ where they were found."
(defun etags-tags-completion-table ()
- (let ((table (make-vector 511 0)))
+ (let ((table (make-vector 511 0))
+ (point-max (/ (float (point-max)) 100.0))
+ (msg-fmt (format
+ "Making tags completion table for %s...%%d%%%%"
+ buffer-file-name)))
(save-excursion
(goto-char (point-min))
;; This monster regexp matches an etags tag line.
@@ -1264,11 +1268,12 @@ where they were found."
\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\
\\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n"
nil t)
- (intern (if (match-beginning 5)
- ;; There is an explicit tag name.
- (buffer-substring (match-beginning 5) (match-end 5))
- ;; No explicit tag name. Best guess.
- (buffer-substring (match-beginning 3) (match-end 3)))
+ (intern (prog1 (if (match-beginning 5)
+ ;; There is an explicit tag name.
+ (buffer-substring (match-beginning 5) (match-end 5))
+ ;; No explicit tag name. Best guess.
+ (buffer-substring (match-beginning 3) (match-end 3)))
+ (message msg-fmt (/ (point) point-max)))
table)))
table))
@@ -1866,6 +1871,7 @@ directory specification."
(or gotany
(error "File %s not in current tags tables" file)))))
(with-current-buffer "*Tags List*"
+ (require 'apropos)
(apropos-mode)
(setq buffer-read-only t)))
@@ -1884,6 +1890,7 @@ directory specification."
(funcall tags-apropos-function regexp))))
(etags-tags-apropos-additional regexp))
(with-current-buffer "*Tags List*"
+ (require 'apropos)
(apropos-mode)
;; apropos-mode is derived from fundamental-mode and it kills
;; all local variables.
diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el
index 11553a1fdb6..53165fbecb7 100644
--- a/lisp/progmodes/f90.el
+++ b/lisp/progmodes/f90.el
@@ -153,7 +153,7 @@
;;; Code:
;; TODO
-;; Support for hideshow, align.
+;; Support for align.
;; OpenMP, preprocessor highlighting.
(defvar comment-auto-fill-only-comments)
@@ -589,6 +589,53 @@ characters long.")
(make-variable-buffer-local 'f90-cache-position)
+;; Hideshow support.
+(defconst f90-end-block-re
+ (concat "^[ \t0-9]*\\<end\\>[ \t]*"
+ (regexp-opt '("do" "if" "forall" "function" "interface"
+ "module" "program" "select" "subroutine"
+ "type" "where" ) t)
+ "[ \t]*\\sw*")
+ "Regexp matching the end of a \"block\" of F90 code.
+Used in the F90 entry in `hs-special-modes-alist'.")
+
+;; Ignore the fact that FUNCTION, SUBROUTINE, WHERE, FORALL have a
+;; following "(". DO, CASE, IF can have labels; IF must be
+;; accompanied by THEN.
+;; A big problem is that many of these statements can be broken over
+;; lines, even with embedded comments. We only try to handle this for
+;; IF ... THEN statements, assuming and hoping it will be less common
+;; for other constructs. We match up to one new-line, provided ")
+;; THEN" appears on one line. Matching on just ") THEN" is no good,
+;; since that includes ELSE branches.
+;; For a fully accurate solution, hideshow would probably have to be
+;; modified to allow functions as well as regexps to be used to
+;; specify block start and end positions.
+(defconst f90-start-block-re
+ (concat
+ "^[ \t0-9]*" ; statement number
+ "\\(\\("
+ "\\(\\sw+[ \t]*:[ \t]*\\)?" ; structure label
+ "\\(do\\|select[ \t]*case\\|if[ \t]*(.*\n?.*)[ \t]*then\\|"
+ ;; Distinguish WHERE block from isolated WHERE.
+ "\\(where\\|forall\\)[ \t]*(.*)[ \t]*\\(!\\|$\\)\\)\\)"
+ "\\|"
+ "program\\|interface\\|module\\|type\\|function\\|subroutine"
+ ;; ") THEN" at line end. Problem - also does ELSE.
+;;; "\\|.*)[ \t]*then[ \t]*\\($\\|!\\)"
+ "\\)"
+ "[ \t]*")
+ "Regexp matching the start of a \"block\" of F90 code.
+A simple regexp cannot do this in fully correct fashion, so this
+tries to strike a compromise between complexity and flexibility.
+Used in the F90 entry in `hs-special-modes-alist'.")
+
+;; hs-special-modes-alist is autoloaded.
+(add-to-list 'hs-special-modes-alist
+ `(f90-mode ,f90-start-block-re ,f90-end-block-re
+ "!" f90-end-of-block nil))
+
+
;; Imenu support.
(defvar f90-imenu-generic-expression
(let ((good-char "[^!\"\&\n \t]") (not-e "[^e!\n\"\& \t]")
@@ -850,14 +897,16 @@ line-number before indenting."
(defsubst f90-get-present-comment-type ()
"If point lies within a comment, return the string starting the comment.
-For example, \"!\" or \"!!\"."
+For example, \"!\" or \"!!\", followed by the appropriate amount of
+whitespace, if any."
+ ;; Include the whitespace for consistent auto-filling of comment blocks.
(save-excursion
(when (f90-in-comment)
(beginning-of-line)
- (re-search-forward "!+" (line-end-position))
+ (re-search-forward "!+[ \t]*" (line-end-position))
(while (f90-in-string)
- (re-search-forward "!+" (line-end-position)))
- (match-string 0))))
+ (re-search-forward "!+[ \t]*" (line-end-position)))
+ (match-string-no-properties 0))))
(defsubst f90-equal-symbols (a b)
"Compare strings A and B neglecting case and allowing for nil value."
@@ -1519,6 +1568,7 @@ is non-nil, call `f90-update-line' after inserting the continuation marker."
(cond ((f90-in-string)
(insert "&\n&"))
((f90-in-comment)
+ (delete-horizontal-space 'backwards) ; remove trailing whitespace
(insert "\n" (f90-get-present-comment-type)))
(t (insert "&")
(or no-update (f90-update-line))
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
new file mode 100644
index 00000000000..2cd62eeecee
--- /dev/null
+++ b/lisp/progmodes/flymake.el
@@ -0,0 +1,2504 @@
+;;; flymake.el -- a universal on-the-fly syntax checker
+
+;; Copyright (C) 2003 Free Software Foundation
+
+;; Author: Pavel Kobiakov <pk_at_work@yahoo.com>
+;; Maintainer: Pavel Kobiakov <pk_at_work@yahoo.com>
+;; Version: 0.3
+;; Keywords: c languages tools
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;;
+;; Flymake is a minor Emacs mode performing on-the-fly syntax
+;; checks using the external syntax check tool (for C/C++ this
+;; is usually the compiler)
+
+;;; Code:
+
+;;;_* Provide
+(provide 'flymake)
+
+;;;; [[ Overlay compatibility
+(autoload 'make-overlay "overlay" "Overlay compatibility kit." t)
+(autoload 'overlayp "overlay" "Overlay compatibility kit." t)
+(autoload 'overlays-in "overlay" "Overlay compatibility kit." t)
+(autoload 'delete-overlay "overlay" "Overlay compatibility kit." t)
+(autoload 'overlay-put "overlay" "Overlay compatibility kit." t)
+(autoload 'overlay-get "overlay" "Overlay compatibility kit." t)
+;;;; ]]
+
+;;;; [[ cross-emacs compatibility routines
+(defvar flymake-emacs
+ (cond
+ ((string-match "XEmacs" emacs-version) 'xemacs)
+ (t 'emacs)
+ )
+ "Currently used emacs flavor"
+)
+
+(defun flymake-makehash(&optional test)
+ (cond
+ ((equal flymake-emacs 'xemacs) (if test (make-hash-table :test test) (make-hash-table)))
+ (t (makehash test))
+ )
+)
+
+(defun flymake-time-to-float(&optional tm)
+ "Convert `current-time` to a float number of seconds."
+ (multiple-value-bind (s0 s1 s2) (or tm (current-time))
+ (+ (* (float (ash 1 16)) s0) (float s1) (* 0.0000001 s2)))
+)
+(defun flymake-float-time()
+ (cond
+ ((equal flymake-emacs 'xemacs) (flymake-time-to-float (current-time)))
+ (t (float-time))
+ )
+)
+
+(defun flymake-replace-regexp-in-string(regexp rep str)
+ (cond
+ ((equal flymake-emacs 'xemacs) (replace-in-string str regexp rep))
+ (t (replace-regexp-in-string regexp rep str))
+ )
+)
+
+(defun flymake-split-string-remove-empty-edges(str pattern)
+ "split, then remove first and/or last in case it's empty"
+ (let* ((splitted (split-string str pattern)))
+ (if (and (> (length splitted) 0) (= 0 (length (elt splitted 0))))
+ (setq splitted (cdr splitted))
+ )
+ (if (and (> (length splitted) 0) (= 0 (length (elt splitted (1- (length splitted))))))
+ (setq splitted (reverse (cdr (reverse splitted))))
+ )
+ splitted
+ )
+)
+(defun flymake-split-string(str pattern)
+ (cond
+ ((equal flymake-emacs 'xemacs) (flymake-split-string-remove-empty-edges str pattern))
+ (t (split-string str pattern))
+ )
+)
+
+(defun flymake-get-temp-dir()
+ (cond
+ ((equal flymake-emacs 'xemacs) (temp-directory))
+ (t temporary-file-directory)
+ )
+)
+
+(defun flymake-line-beginning-position()
+ (save-excursion
+ (beginning-of-line)
+ (point)
+ )
+)
+
+(defun flymake-line-end-position()
+ (save-excursion
+ (end-of-line)
+ (point)
+ )
+)
+
+(defun flymake-popup-menu(pos menu-data)
+ (cond
+ ((equal flymake-emacs 'xemacs)
+ (let* ((x-pos (nth 0 (nth 0 pos)))
+ (y-pos (nth 1 (nth 0 pos)))
+ (fake-event-props '(button 1 x 1 y 1)))
+ (setq fake-event-props (plist-put fake-event-props 'x x-pos))
+ (setq fake-event-props (plist-put fake-event-props 'y y-pos))
+ (popup-menu (flymake-make-xemacs-menu menu-data) (make-event 'button-press fake-event-props))
+ )
+ )
+ (t (x-popup-menu pos (flymake-make-emacs-menu menu-data)))
+ )
+)
+
+(defun flymake-make-emacs-menu(menu-data)
+ (let* ((menu-title (nth 0 menu-data))
+ (menu-items (nth 1 menu-data))
+ (menu-commands nil))
+
+ (setq menu-commands (mapcar (lambda (foo)
+ (cons (nth 0 foo) (nth 1 foo)))
+ menu-items))
+ (list menu-title (cons "" menu-commands))
+ )
+)
+
+(defun flymake-nop()
+)
+
+(defun flymake-make-xemacs-menu(menu-data)
+ (let* ((menu-title (nth 0 menu-data))
+ (menu-items (nth 1 menu-data))
+ (menu-commands nil))
+ (setq menu-commands (mapcar (lambda (foo)
+ (vector (nth 0 foo) (or (nth 1 foo) '(flymake-nop)) t))
+ menu-items))
+ (cons menu-title menu-commands)
+ )
+)
+
+(defun flymake-xemacs-window-edges(&optional window)
+ (let ((edges (window-pixel-edges window))
+ tmp)
+ (setq tmp edges)
+ (setcar tmp (/ (car tmp) (face-width 'default)))
+ (setq tmp (cdr tmp))
+ (setcar tmp (/ (car tmp) (face-height 'default)))
+ (setq tmp (cdr tmp))
+ (setcar tmp (/ (car tmp) (face-width 'default)))
+ (setq tmp (cdr tmp))
+ (setcar tmp (/ (car tmp) (face-height 'default)))
+ edges
+ )
+)
+
+(defun flymake-current-row()
+ "return current row in current frame"
+ (cond
+ ((equal flymake-emacs 'xemacs) (count-lines (window-start) (point)))
+ (t (+ (car (cdr (window-edges))) (count-lines (window-start) (point))))
+ )
+)
+
+(defun flymake-selected-frame()
+ (cond
+ ((equal flymake-emacs 'xemacs) (selected-window))
+ (t (selected-frame))
+ )
+)
+
+;;;; ]]
+
+(defcustom flymake-log-level -1
+ "Logging level, only messages with level > flymake-log-level will not be logged
+-1 = NONE, 0 = ERROR, 1 = WARNING, 2 = INFO, 3 = DEBUG"
+ :group 'flymake
+ :type 'integer
+)
+
+(defun flymake-log(level text &rest args)
+ "Log a message with optional arguments"
+ (if (<= level flymake-log-level)
+ (let* ((msg (apply 'format text args)))
+ (message msg)
+ ;(with-temp-buffer
+ ; (insert msg)
+ ; (insert "\n")
+ ; (flymake-save-buffer-in-file (current-buffer) "d:/flymake.log" t) ; make log file name customizable
+ ;)
+ )
+ )
+)
+
+(defun flymake-ins-after(list pos val)
+ "insert val into list after position pos"
+ (let ((tmp (copy-sequence list))) ; (???)
+ (setcdr (nthcdr pos tmp) (cons val (nthcdr (1+ pos) tmp)))
+ tmp
+ )
+)
+
+(defun flymake-set-at(list pos val)
+ "set val at position pos in list"
+ (let ((tmp (copy-sequence list))) ; (???)
+ (setcar (nthcdr pos tmp) val)
+ tmp
+ )
+)
+
+(defvar flymake-pid-to-names(flymake-makehash)
+ "pid -> source buffer name, output file name mapping"
+)
+
+(defun flymake-reg-names(pid source-buffer-name)
+ "Save into in pid map"
+ (unless (stringp source-buffer-name)
+ (error "invalid buffer name")
+ )
+ (puthash pid (list source-buffer-name) flymake-pid-to-names)
+)
+
+(defun flymake-get-source-buffer-name(pid)
+ "Return buffer name stored in pid map"
+ (nth 0 (gethash pid flymake-pid-to-names))
+)
+
+(defun flymake-unreg-names(pid)
+ "Delete pid->buffer name mapping"
+ (remhash pid flymake-pid-to-names)
+)
+
+(defun flymake-get-buffer-var(buffer var-name)
+ "switch to buffer if necessary and return local variable var"
+ (unless (bufferp buffer)
+ (error "invalid buffer")
+ )
+
+ (if (eq buffer (current-buffer))
+ (symbol-value var-name)
+ ;else
+ (save-excursion
+ (set-buffer buffer)
+ (symbol-value var-name)
+ )
+ )
+)
+
+(defun flymake-set-buffer-var(buffer var-name var-value)
+ "switch to buffer if necessary and set local variable var-name to var-value"
+ (unless (bufferp buffer)
+ (error "invalid buffer")
+ )
+
+ (if (eq buffer (current-buffer))
+ (set var-name var-value)
+ ;else
+ (save-excursion
+ (set-buffer buffer)
+ (set var-name var-value)
+ )
+ )
+)
+
+(defvar flymake-buffer-data(flymake-makehash)
+ "data specific to syntax check tool, in name-value pairs"
+)
+(make-variable-buffer-local 'flymake-buffer-data)
+(defun flymake-get-buffer-data(buffer)
+ (flymake-get-buffer-var buffer 'flymake-buffer-data)
+)
+(defun flymake-set-buffer-data(buffer data)
+ (flymake-set-buffer-var buffer 'flymake-buffer-data data)
+)
+(defun flymake-get-buffer-value(buffer name)
+ (gethash name (flymake-get-buffer-data buffer))
+)
+(defun flymake-set-buffer-value(buffer name value)
+ (puthash name value (flymake-get-buffer-data buffer))
+)
+
+(defvar flymake-output-residual nil
+ ""
+)
+(make-variable-buffer-local 'flymake-output-residual)
+(defun flymake-get-buffer-output-residual(buffer)
+ (flymake-get-buffer-var buffer 'flymake-output-residual)
+)
+(defun flymake-set-buffer-output-residual(buffer residual)
+ (flymake-set-buffer-var buffer 'flymake-output-residual residual)
+)
+
+(defcustom flymake-allowed-file-name-masks '((".+\\.c$" flymake-simple-make-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.cpp$" flymake-simple-make-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.xml$" flymake-xml-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.html?$" flymake-xml-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.cs$" flymake-simple-make-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.pl$" flymake-perl-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.h$" flymake-master-make-header-init flymake-master-cleanup flymake-get-real-file-name)
+ (".+\\.java$" flymake-simple-make-java-init flymake-simple-java-cleanup flymake-get-real-file-name)
+ (".+[0-9]+\\.tex$" flymake-master-tex-init flymake-master-cleanup flymake-get-real-file-name)
+ (".+\\.tex$" flymake-simple-tex-init flymake-simple-cleanup flymake-get-real-file-name)
+ (".+\\.idl$" flymake-simple-make-init flymake-simple-cleanup flymake-get-real-file-name)
+; (".+\\.cpp$" 1)
+; (".+\\.java$" 3)
+; (".+\\.h$" 2 (".+\\.cpp$" ".+\\.c$")
+; ("[ \t]*#[ \t]*include[ \t]*\"\\([\w0-9/\\_\.]*[/\\]*\\)\\(%s\\)\"" 1 2))
+; (".+\\.idl$" 1)
+; (".+\\.odl$" 1)
+; (".+[0-9]+\\.tex$" 2 (".+\\.tex$")
+; ("[ \t]*\\input[ \t]*{\\(.*\\)\\(%s\\)}" 1 2 ))
+; (".+\\.tex$" 1)
+ )
+ "*Files syntax checking is allowed for"
+ :group 'flymake
+ :type '(repeat (string symbol symbol symbol))
+)
+
+(defun flymake-get-file-name-mode-and-masks(file-name)
+ "return the corresponding entry from flymake-allowed-file-name-masks"
+ (unless (stringp file-name)
+ (error "invalid file-name")
+ )
+ (let ((count (length flymake-allowed-file-name-masks))
+ (idx 0)
+ (mode-and-masks nil))
+ (while (and (not mode-and-masks) (< idx count))
+ (if (string-match (nth 0 (nth idx flymake-allowed-file-name-masks)) file-name)
+ (setq mode-and-masks (cdr (nth idx flymake-allowed-file-name-masks)))
+ )
+ (setq idx (1+ idx))
+ )
+ (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks))
+ mode-and-masks
+ )
+)
+
+(defun flymake-can-syntax-check-file(file-name)
+ "Determine whether we can syntax check file-name: nil if cannot, non-nil if can"
+ (if (flymake-get-init-function file-name)
+ t
+ ;else
+ nil
+ )
+)
+
+(defun flymake-get-init-function(file-name)
+ "return init function to be used for the file"
+ (let* ((init-f (nth 0 (flymake-get-file-name-mode-and-masks file-name))))
+ ;(flymake-log 0 "calling %s" init-f)
+ ;(funcall init-f (current-buffer))
+ )
+ (nth 0 (flymake-get-file-name-mode-and-masks file-name))
+)
+
+(defun flymake-get-cleanup-function(file-name)
+ "return cleanup function to be used for the file"
+ (nth 1 (flymake-get-file-name-mode-and-masks file-name))
+)
+
+(defun flymake-get-real-file-name-function(file-name)
+ ""
+ (or (nth 2 (flymake-get-file-name-mode-and-masks file-name)) 'flymake-get-real-file-name)
+)
+
+(defcustom flymake-buildfile-dirs '("." ".." "../.." "../../.." "../../../.." "../../../../.." "../../../../../.." "../../../../../../.." "../../../../../../../.." "../../../../../../../../.." "../../../../../../../../../.." "../../../../../../../../../../..")
+ "dirs to look for buildfile"
+ :group 'flymake
+ :type '(repeat (string))
+)
+
+(defvar flymake-find-buildfile-cache (flymake-makehash 'equal))
+(defun flymake-get-buildfile-from-cache(dir-name)
+ (gethash dir-name flymake-find-buildfile-cache)
+)
+(defun flymake-add-buildfile-to-cache(dir-name buildfile)
+ (puthash dir-name buildfile flymake-find-buildfile-cache)
+)
+(defun flymake-clear-buildfile-cache()
+ (clrhash flymake-find-buildfile-cache)
+)
+
+(defun flymake-find-buildfile(buildfile-name source-dir-name dirs)
+ "find buildfile (i.e. Makefile, build.xml, etc.) starting from current directory. Return its path or nil if not found"
+ (if (flymake-get-buildfile-from-cache source-dir-name)
+ (progn
+ (flymake-get-buildfile-from-cache source-dir-name)
+ )
+ ;else
+ (let* ((buildfile-dir nil)
+ (buildfile nil)
+ (dir-count (length dirs))
+ (dir-idx 0)
+ (found nil))
+
+ (while (and (not found) (< dir-idx dir-count))
+
+ (setq buildfile-dir (concat source-dir-name (nth dir-idx dirs)))
+ (setq buildfile (concat buildfile-dir "/" buildfile-name))
+
+ (when (file-exists-p buildfile)
+ (setq found t)
+ )
+
+ (setq dir-idx (1+ dir-idx))
+ )
+ (if found
+ (progn
+ (flymake-log 3 "found buildfile at %s/%s" buildfile-dir buildfile-name)
+ (flymake-add-buildfile-to-cache source-dir-name buildfile-dir)
+ buildfile-dir
+ )
+ ;else
+ (progn
+ (flymake-log 3 "buildfile for %s not found" source-dir-name)
+ nil
+ )
+ )
+ )
+ )
+)
+
+(defun flymake-fix-path-name(name)
+ "replace all occurences of '\' with '/'"
+ (when name
+ (let* ((new-name (flymake-replace-regexp-in-string "[\\]" "/" (expand-file-name name)))
+ (last-char (elt new-name (1- (length new-name)))))
+ (setq new-name (flymake-replace-regexp-in-string "\\./" "" new-name))
+ (if (equal "/" (char-to-string last-char))
+ (setq new-name (substring new-name 0 (1- (length new-name))))
+ )
+ new-name
+ )
+ )
+)
+
+(defun flymake-same-files(file-name-one file-name-two)
+ "t if file-name-one and file-name-two actually point to the same file"
+ (equal (flymake-fix-path-name file-name-one) (flymake-fix-path-name file-name-two))
+)
+
+(defun flymake-ensure-ends-with-slash(path)
+ (if (not (= (elt path (1- (length path))) (string-to-char "/")))
+ (concat path "/")
+ ;else
+ path
+ )
+)
+
+(defun flymake-get-common-path-prefix(string-one string-two)
+ "return common prefix for two paths"
+ (when (and string-one string-two)
+ (let* ((slash-pos-one -1)
+ (slash-pos-two -1)
+ (done nil)
+ (prefix nil))
+
+ (setq string-one (flymake-ensure-ends-with-slash string-one))
+ (setq string-two (flymake-ensure-ends-with-slash string-two))
+
+ (while (not done)
+ (setq slash-pos-one (string-match "/" string-one (1+ slash-pos-one)))
+ (setq slash-pos-two (string-match "/" string-two (1+ slash-pos-two)))
+
+ (if (and slash-pos-one slash-pos-two
+ (= slash-pos-one slash-pos-two)
+ (string= (substring string-one 0 slash-pos-one) (substring string-two 0 slash-pos-two)))
+ (progn
+ (setq prefix (substring string-one 0 (1+ slash-pos-one)))
+ )
+ ;else
+ (setq done t)
+ )
+ )
+ prefix
+ )
+ )
+)
+
+(defun flymake-build-relative-path(from-dir to-dir)
+ "return rel: from-dir/rel == to-dir"
+ (if (not (equal (elt from-dir 0) (elt to-dir 0)))
+ (error "first chars in paths %s, %s must be equal (same drive)" from-dir to-dir)
+ ;else
+ (let* ((from (flymake-ensure-ends-with-slash (flymake-fix-path-name from-dir)))
+ (to (flymake-ensure-ends-with-slash (flymake-fix-path-name to-dir)))
+ (prefix (flymake-get-common-path-prefix from to))
+ (from-suffix (substring from (length prefix)))
+ (up-count (length (flymake-split-string from-suffix "[/]")))
+ (to-suffix (substring to (length prefix)))
+ (idx 0)
+ (rel nil))
+
+ (if (and (> (length to-suffix) 0) (equal "/" (char-to-string (elt to-suffix 0))))
+ (setq to-suffix (substring to-suffix 1))
+ )
+
+ (while (< idx up-count)
+ (if (> (length rel) 0)
+ (setq rel (concat rel "/"))
+ )
+ (setq rel (concat rel ".."))
+ (setq idx (1+ idx))
+ )
+ (if (> (length rel) 0)
+ (setq rel (concat rel "/"))
+ )
+ (if (> (length to-suffix) 0)
+ (setq rel (concat rel to-suffix))
+ )
+
+ (or rel "./")
+ )
+ )
+)
+
+(defcustom flymake-master-file-dirs '("." "./src" "./UnitTest")
+ "dirs where to llok for master files"
+ :group 'flymake
+ :type '(repeat (string))
+)
+
+(defcustom flymake-master-file-count-limit 32
+ "max number of master files to check"
+ :group 'flymake
+ :type 'integer
+)
+
+(defun flymake-find-possible-master-files(file-name master-file-dirs masks)
+ "find (by name and location) all posible master files, which are .cpp and .c for and .h.
+Files are searched for starting from the .h directory and max max-level parent dirs.
+File contents are not checked."
+ (let* ((dir-idx 0)
+ (dir-count (length master-file-dirs))
+ (files nil)
+ (done nil)
+ (masks-count (length masks)))
+
+ (while (and (not done) (< dir-idx dir-count))
+ (let* ((dir (concat (flymake-fix-path-name (file-name-directory file-name)) "/" (nth dir-idx master-file-dirs)))
+ (masks-idx 0))
+ (while (and (file-exists-p dir) (not done) (< masks-idx masks-count))
+ (let* ((mask (nth masks-idx masks))
+ (dir-files (directory-files dir t mask))
+ (file-count (length dir-files))
+ (file-idx 0))
+
+ (flymake-log 3 "dir %s, %d file(s) for mask %s" dir file-count mask)
+ (while (and (not done) (< file-idx file-count))
+ (when (not (file-directory-p (nth file-idx dir-files)))
+ (setq files (cons (nth file-idx dir-files) files))
+ (when (>= (length files) flymake-master-file-count-limit)
+ (flymake-log 3 "master file count limit (%d) reached" flymake-master-file-count-limit)
+ (setq done t)
+ )
+ )
+ (setq file-idx (1+ file-idx))
+ )
+ )
+ (setq masks-idx (1+ masks-idx))
+ )
+ )
+ (setq dir-idx (1+ dir-idx))
+ )
+ (when files
+ (setq flymake-included-file-name (file-name-nondirectory file-name))
+ (setq files (sort files 'flymake-master-file-compare))
+ (setq flymake-included-file-name nil)
+ )
+ (flymake-log 3 "found %d possible master file(s)" (length files))
+ files
+ )
+)
+
+(defvar flymake-included-file-name nil ; this is used to pass a parameter to a sort predicate below
+ ""
+)
+
+(defun flymake-master-file-compare(file-one file-two)
+ "used in sort to move most possible file names to the beginning of the list (File.h -> File.cpp moved to top"
+ (and (equal (file-name-sans-extension flymake-included-file-name)
+ (file-name-sans-extension (file-name-nondirectory file-one)))
+ (not (equal file-one file-two))
+ )
+)
+
+(defcustom flymake-check-file-limit 8192
+ "max number of chars to look at when checking possible master file"
+ :group 'flymake
+ :type 'integer
+)
+
+(defun flymake-check-patch-master-file-buffer(master-file-temp-buffer
+ master-file-name patched-master-file-name
+ source-file-name patched-source-file-name
+ include-dirs regexp-list)
+ "check whether master-file-name is indeed a master file for source-file-name.
+For .cpp master file this means it includes source-file-name (.h).
+If yes, patch a copy of master-file-name to include patched-source-file-name instead of source-file-name.
+Whenether a buffer for master-file-name exists, use it as a source instead of reading master file from disk"
+ (let* ((found nil)
+ (regexp (format (nth 0 regexp-list) ; "[ \t]*#[ \t]*include[ \t]*\"\\([\w0-9/\\_\.]*[/\\]*\\)\\(%s\\)\""
+ (file-name-nondirectory source-file-name)))
+ (path-idx (nth 1 regexp-list))
+ (name-idx (nth 2 regexp-list))
+ (inc-path nil)
+ (inc-name nil)
+ (search-limit flymake-check-file-limit))
+ (save-excursion
+ (unwind-protect
+ (progn
+ (set-buffer master-file-temp-buffer)
+ (when (> search-limit (point-max))
+ (setq search-limit (point-max))
+ )
+ (flymake-log 3 "checking %s against regexp %s" master-file-name regexp)
+ (goto-char (point-min))
+ (while (and (< (point) search-limit) (re-search-forward regexp search-limit t))
+ (let* ((match-beg (match-beginning name-idx))
+ (match-end (match-end name-idx)))
+
+ (flymake-log 3 "found possible match for %s" (file-name-nondirectory source-file-name))
+ (setq inc-path (match-string path-idx))
+ (setq inc-name (match-string name-idx))
+ (when (string= inc-name (file-name-nondirectory source-file-name))
+ (flymake-log 3 "inc-path=%s inc-name=%s" inc-path inc-name)
+ (when (flymake-check-include source-file-name inc-path inc-name include-dirs)
+ (setq found t)
+ ; replace-match is not used here as it fails in xemacs with
+ ; 'last match not a buffer' error as check-includes calls replace-in-string
+ (flymake-replace-region (current-buffer) match-beg match-end
+ (file-name-nondirectory patched-source-file-name))
+ )
+ )
+ (forward-line 1)
+ )
+ )
+ (when found
+ (flymake-save-buffer-in-file (current-buffer) patched-master-file-name)
+ )
+ )
+ ;+(flymake-log 3 "killing buffer %s" (buffer-name master-file-temp-buffer))
+ (kill-buffer master-file-temp-buffer)
+ )
+ )
+ ;+(flymake-log 3 "check-patch master file %s: %s" master-file-name found)
+ (when found
+ (flymake-log 2 "found master file %s" master-file-name)
+ )
+ found
+ )
+)
+
+(defun flymake-replace-region(buffer beg end rep)
+ "replace text in buffer in region (beg; end) with rep"
+ (save-excursion
+ (delete-region beg end)
+ (goto-char beg)
+ (insert rep)
+ )
+)
+
+(defun flymake-read-file-to-temp-buffer(file-name)
+ "isert contents of file-name into newly created temp buffer"
+ (let* ((temp-buffer (get-buffer-create (generate-new-buffer-name (concat "flymake:" (file-name-nondirectory file-name))))))
+ (save-excursion
+ (set-buffer temp-buffer)
+ (insert-file-contents file-name)
+ )
+ temp-buffer
+ )
+)
+
+(defun flymake-copy-buffer-to-temp-buffer(buffer)
+ "copy contents of buffer into newly created temp buffer"
+ (let ((contents nil)
+ (temp-buffer nil))
+ (save-excursion
+ (set-buffer buffer)
+ (setq contents (buffer-string))
+
+ (setq temp-buffer (get-buffer-create (generate-new-buffer-name (concat "flymake:" (buffer-name buffer)))))
+ (set-buffer temp-buffer)
+ (insert contents)
+ )
+ temp-buffer
+ )
+)
+
+(defun flymake-check-include(source-file-name inc-path inc-name include-dirs)
+ "t if source-file-name is the one found via include dirs using inc-path and inc-name"
+ (if (file-name-absolute-p inc-path)
+ (flymake-same-files source-file-name (concat inc-path "/" inc-name))
+ ;else
+ (let* ((count (length include-dirs))
+ (idx 0)
+ (file-name nil)
+ (found nil))
+ (while (and (not found) (< idx count))
+ (setq file-name (concat (file-name-directory source-file-name) "/" (nth idx include-dirs)))
+ (if (> (length inc-path) 0)
+ (setq file-name (concat file-name "/" inc-path))
+ )
+ (setq file-name (concat file-name "/" inc-name))
+ (when (flymake-same-files source-file-name file-name)
+ (setq found t)
+ )
+ (setq idx (1+ idx))
+ )
+ found
+ )
+ )
+)
+
+(defun flymake-find-buffer-for-file(file-name)
+ "buffer if there exists a buffer visiting file-name, nil otherwise"
+ (let ((buffer-name (get-file-buffer file-name)))
+ (if buffer-name
+ (get-buffer buffer-name)
+ )
+ )
+)
+
+(defun flymake-create-master-file(source-file-name patched-source-file-name get-incl-dirs-f create-temp-f masks include-regexp-list)
+ "save source-file-name with a different name, find master file, patch it and save it to."
+ (let* ((possible-master-files (flymake-find-possible-master-files source-file-name flymake-master-file-dirs masks))
+ (master-file-count (length possible-master-files))
+ (idx 0)
+ (temp-buffer nil)
+ (master-file-name nil)
+ (patched-master-file-name nil)
+ (found nil))
+
+ (while (and (not found) (< idx master-file-count))
+ (setq master-file-name (nth idx possible-master-files))
+ (setq patched-master-file-name (funcall create-temp-f master-file-name "flymake_master"))
+ (if (flymake-find-buffer-for-file master-file-name)
+ (setq temp-buffer (flymake-copy-buffer-to-temp-buffer (flymake-find-buffer-for-file master-file-name)))
+ ;else
+ (setq temp-buffer (flymake-read-file-to-temp-buffer master-file-name))
+ )
+ (setq found
+ (flymake-check-patch-master-file-buffer
+ temp-buffer
+ master-file-name
+ patched-master-file-name
+ source-file-name
+ patched-source-file-name
+ (funcall get-incl-dirs-f (file-name-directory master-file-name))
+ include-regexp-list))
+ (setq idx (1+ idx))
+ )
+ (if found
+ (list master-file-name patched-master-file-name)
+ ;else
+ (progn
+ (flymake-log 3 "none of %d master file(s) checked includes %s" master-file-count
+ (file-name-nondirectory source-file-name))
+ nil
+ )
+ )
+ )
+)
+
+(defun flymake-save-buffer-in-file(buffer file-name)
+ (or buffer
+ (error "invalid buffer")
+ )
+ (save-excursion
+ (save-restriction
+ (set-buffer buffer)
+ (widen)
+ (make-directory (file-name-directory file-name) 1)
+ (write-region (point-min) (point-max) file-name nil 566)
+ )
+ )
+ (flymake-log 3 "saved buffer %s in file %s" (buffer-name buffer) file-name)
+)
+
+(defun flymake-save-string-to-file(file-name data)
+ "save string data to file file-name"
+ (write-region data nil file-name nil 566)
+)
+
+(defun flymake-read-file-to-string(file-name)
+ "read file contents and return them as a string"
+ (with-temp-buffer
+ (insert-file-contents file-name)
+ (buffer-substring (point-min) (point-max))
+ )
+)
+
+(defun flymake-process-filter(process output)
+ "flymake process filter: parse output, highlight err lines"
+ (let* ((pid (process-id process))
+ (source-buffer (get-buffer (flymake-get-source-buffer-name pid))))
+
+ (flymake-log 3 "received %d byte(s) of output from process %d" (length output) pid)
+ (when source-buffer
+ (flymake-parse-output-and-residual source-buffer output)
+ )
+ )
+)
+
+(defun flymake-process-sentinel(process event)
+ "Sentinel for syntax check buffers"
+ (if (memq (process-status process) '(signal exit))
+ (let*((exit-status (process-exit-status process))
+ (command (process-command process))
+ (pid (process-id process))
+ (source-buffer (get-buffer (flymake-get-source-buffer-name pid)))
+ (cleanup-f (flymake-get-cleanup-function (buffer-file-name source-buffer))))
+
+ (flymake-log 2 "process %d exited with code %d" pid exit-status)
+ (condition-case err
+ (progn
+ (flymake-log 3 "cleaning up using %s" cleanup-f)
+ (funcall cleanup-f source-buffer)
+
+ (flymake-unreg-names pid)
+ (delete-process process)
+
+ (when source-buffer
+ (save-excursion
+ (set-buffer source-buffer)
+
+ (flymake-parse-residual source-buffer)
+ (flymake-post-syntax-check source-buffer)
+ (flymake-set-buffer-is-running source-buffer nil)
+ )
+ )
+ )
+ (error
+ (let ((err-str (format "Error in process sentinel for buffer %s: %s"
+ source-buffer (error-message-string err))))
+ (flymake-log 0 err-str)
+ (flymake-set-buffer-is-running source-buffer nil)
+ )
+ )
+ )
+ )
+ )
+)
+
+(defun flymake-post-syntax-check(source-buffer)
+ ""
+ (flymake-set-buffer-err-info source-buffer (flymake-get-buffer-new-err-info source-buffer))
+ (flymake-set-buffer-new-err-info source-buffer nil)
+
+ (flymake-set-buffer-err-info source-buffer (flymake-fix-line-numbers
+ (flymake-get-buffer-err-info source-buffer)
+ 1
+ (flymake-count-lines source-buffer)))
+ (flymake-delete-own-overlays source-buffer)
+ (flymake-highlight-err-lines source-buffer (flymake-get-buffer-err-info source-buffer))
+
+ (let ((err-count (flymake-get-err-count (flymake-get-buffer-err-info source-buffer) "e"))
+ (warn-count (flymake-get-err-count (flymake-get-buffer-err-info source-buffer) "w")))
+
+ (flymake-log 2 "%s: %d error(s), %d warning(s) in %.2f second(s)"
+ (buffer-name source-buffer) err-count warn-count
+ (- (flymake-float-time) (flymake-get-buffer-check-start-time source-buffer)))
+ (flymake-set-buffer-check-start-time source-buffer nil)
+ (if (and (equal 0 err-count) (equal 0 warn-count))
+ (if (equal 0 exit-status)
+ (flymake-report-status source-buffer "" "") ; PASSED
+ ;else
+ (if (not (flymake-get-buffer-check-was-interrupted source-buffer))
+ (flymake-report-fatal-status (current-buffer) "CFGERR"
+ (format "Configuration error has occured while running %s" command))
+ ;else
+ (flymake-report-status source-buffer nil "") ; "STOPPED"
+ )
+ )
+ ;else
+ (flymake-report-status source-buffer (format "%d/%d" err-count warn-count) "")
+ )
+ )
+)
+
+(defun flymake-parse-output-and-residual(source-buffer output)
+ "split output into lines, merge in residual if necessary"
+ (save-excursion
+ (set-buffer source-buffer)
+ (let* ((buffer-residual (flymake-get-buffer-output-residual source-buffer))
+ (total-output (if buffer-residual (concat buffer-residual output) output))
+ (lines-and-residual (flymake-split-output total-output))
+ (lines (nth 0 lines-and-residual))
+ (new-residual (nth 1 lines-and-residual)))
+
+ (flymake-set-buffer-output-residual source-buffer new-residual)
+ (flymake-set-buffer-new-err-info source-buffer (flymake-parse-err-lines
+ (flymake-get-buffer-new-err-info source-buffer)
+ source-buffer lines))
+ )
+ )
+)
+
+(defun flymake-parse-residual(source-buffer)
+ "parse residual if it's non empty"
+ (save-excursion
+ (set-buffer source-buffer)
+ (when (flymake-get-buffer-output-residual source-buffer)
+ (flymake-set-buffer-new-err-info source-buffer (flymake-parse-err-lines
+ (flymake-get-buffer-new-err-info source-buffer)
+ source-buffer
+ (list (flymake-get-buffer-output-residual source-buffer))))
+ (flymake-set-buffer-output-residual source-buffer nil)
+ )
+ )
+)
+
+(defvar flymake-err-info nil
+ "sorted list of line numbers and lists of err info in the form (file, err-text)."
+)
+(make-variable-buffer-local 'flymake-err-info)
+(defun flymake-get-buffer-err-info(buffer)
+ (flymake-get-buffer-var buffer 'flymake-err-info)
+)
+(defun flymake-set-buffer-err-info(buffer err-info)
+ (flymake-set-buffer-var buffer 'flymake-err-info err-info)
+)
+(defun flymake-er-make-er(line-no line-err-info-list)
+ (list line-no line-err-info-list)
+)
+(defun flymake-er-get-line(err-info)
+ (nth 0 err-info)
+)
+(defun flymake-er-get-line-err-info-list(err-info)
+ (nth 1 err-info)
+)
+
+(defvar flymake-new-err-info nil
+ "the same as flymake -err-info, effective when a syntax check is in progress"
+)
+(make-variable-buffer-local 'flymake-new-err-info)
+(defun flymake-get-buffer-new-err-info(buffer)
+ (flymake-get-buffer-var buffer 'flymake-new-err-info)
+)
+(defun flymake-set-buffer-new-err-info(buffer new-err-info)
+ (flymake-set-buffer-var buffer 'flymake-new-err-info new-err-info)
+)
+
+;; getters/setters for line-err-info: (file, line, type, text).
+(defun flymake-ler-make-ler(file line type text &optional full-file)
+ (list file line type text full-file)
+)
+(defun flymake-ler-get-file(line-err-info)
+ (nth 0 line-err-info)
+)
+(defun flymake-ler-get-line(line-err-info)
+ (nth 1 line-err-info)
+)
+(defun flymake-ler-get-type(line-err-info)
+ (nth 2 line-err-info)
+)
+(defun flymake-ler-get-text(line-err-info)
+ (nth 3 line-err-info)
+)
+(defun flymake-ler-get-full-file(line-err-info)
+ (nth 4 line-err-info)
+)
+(defun flymake-ler-set-file(line-err-info file)
+ (flymake-ler-make-ler file
+ (flymake-ler-get-line line-err-info)
+ (flymake-ler-get-type line-err-info)
+ (flymake-ler-get-text line-err-info)
+ (flymake-ler-get-full-file line-err-info))
+)
+(defun flymake-ler-set-full-file(line-err-info full-file)
+ (flymake-ler-make-ler (flymake-ler-get-file line-err-info)
+ (flymake-ler-get-line line-err-info)
+ (flymake-ler-get-type line-err-info)
+ (flymake-ler-get-text line-err-info)
+ full-file)
+)
+(defun flymake-ler-set-line(line-err-info line)
+ (flymake-ler-make-ler (flymake-ler-get-file line-err-info)
+ line
+ (flymake-ler-get-type line-err-info)
+ (flymake-ler-get-text line-err-info)
+ (flymake-ler-get-full-file line-err-info))
+)
+
+(defun flymake-get-line-err-count(line-err-info-list type)
+ "return number of errors of specified type - e or w"
+ (let* ((idx 0)
+ (count (length line-err-info-list))
+ (err-count 0))
+
+ (while (< idx count)
+ (when (equal type (flymake-ler-get-type (nth idx line-err-info-list)))
+ (setq err-count (1+ err-count))
+ )
+ (setq idx (1+ idx))
+ )
+ err-count
+ )
+)
+
+(defun flymake-get-err-count(err-info-list type)
+ "return number of errors of specified type for the err-info-list"
+ (let* ((idx 0)
+ (count (length err-info-list))
+ (err-count 0))
+ (while (< idx count)
+ (setq err-count (+ err-count (flymake-get-line-err-count (nth 1 (nth idx err-info-list)) type)))
+ (setq idx (1+ idx))
+ )
+ err-count
+ )
+)
+
+(defun flymake-fix-line-numbers(err-info-list min-line max-line)
+ "replace line-numbers < min-line with min-line and > max-line with max-line - as some compilers might report line number outside the file being compiled"
+ (let* ((count (length err-info-list))
+ (err-info nil)
+ (line 0))
+ (while (> count 0)
+ (setq err-info (nth (1- count) err-info-list))
+ (setq line (flymake-er-get-line err-info))
+ (when (or (< line min-line) (> line max-line))
+ (setq line (if (< line min-line) min-line max-line))
+ (setq err-info-list (flymake-set-at err-info-list (1- count)
+ (flymake-er-make-er line
+ (flymake-er-get-line-err-info-list err-info))))
+ )
+ (setq count (1- count))
+ )
+ )
+ err-info-list
+)
+
+(defun flymake-highlight-err-lines(buffer err-info-list)
+ "highlight err-lines in buffer using info from err-info-list"
+ (save-excursion
+ (set-buffer buffer)
+ (let* ((idx 0)
+ (count (length err-info-list)))
+ (while (< idx count)
+ (flymake-highlight-line (car (nth idx err-info-list)) (nth 1 (nth idx err-info-list)))
+ (setq idx (1+ idx))
+ )
+ )
+ )
+)
+
+(defun flymake-overlay-p(ov)
+ "Determine whether overlay was created by flymake"
+ (and (overlayp ov) (overlay-get ov 'flymake-overlay))
+)
+
+(defun flymake-make-overlay(beg end tooltip-text face mouse-face)
+ "Allocate a flymake overlay in range beg end"
+ (when (not (flymake-region-has-flymake-overlays beg end))
+ (let ((ov (make-overlay beg end nil t t)))
+ (overlay-put ov 'face face)
+ (overlay-put ov 'mouse-face mouse-face)
+ (overlay-put ov 'help-echo tooltip-text)
+ (overlay-put ov 'flymake-overlay t)
+ (overlay-put ov 'priority 100)
+ ;+(flymake-log 3 "created overlay %s" ov)
+ ov
+ )
+ (flymake-log 3 "created an overlay at (%d-%d)" beg end)
+ )
+)
+
+(defun flymake-delete-own-overlays(buffer)
+ "Delete all flymake overlays in buffer"
+ (save-excursion
+ (set-buffer buffer)
+ (let ((ov (overlays-in (point-min) (point-max))))
+ (while (consp ov)
+ (when (flymake-overlay-p (car ov))
+ (delete-overlay (car ov))
+ ;+(flymake-log 3 "deleted overlay %s" ov)
+ )
+ (setq ov (cdr ov))
+ )
+ )
+ )
+)
+
+(defun flymake-region-has-flymake-overlays(beg end)
+ "t if specified regions has at least one flymake overlay, nil otrherwise"
+ (let ((ov (overlays-in beg end))
+ (has-flymake-overlays nil))
+ (while (consp ov)
+ (when (flymake-overlay-p (car ov))
+ (setq has-flymake-overlays t)
+ )
+ (setq ov (cdr ov))
+ )
+ )
+)
+
+(defface flymake-errline-face
+;+ '((((class color)) (:foreground "OrangeRed" :bold t :underline t))
+;+ '((((class color)) (:underline "OrangeRed"))
+ '((((class color)) (:background "LightPink"))
+ (t (:bold t)))
+ "Face used for marking error lines"
+ :group 'flymake
+)
+
+(defface flymake-warnline-face
+ '((((class color)) (:background "LightBlue2"))
+ (t (:bold t)))
+ "Face used for marking warning lines"
+ :group 'flymake
+)
+
+
+(defun flymake-highlight-line(line-no line-err-info-list)
+ "highlight line line-no in current buffer, perhaps use text from line-err-info-list to enhance highlighting"
+ (goto-line line-no)
+ (let* ((line-beg (flymake-line-beginning-position))
+ (line-end (flymake-line-end-position))
+ (beg line-beg)
+ (end line-end)
+ (tooltip-text (flymake-ler-get-text (nth 0 line-err-info-list)))
+ (face nil))
+
+ (goto-char line-beg)
+ (while (looking-at "[ \t]")
+ (forward-char)
+ )
+
+ (setq beg (point))
+
+ (goto-char line-end)
+ (while (and (looking-at "[ \t\r\n]") (> (point) 1))
+ (backward-char)
+ )
+
+ (setq end (1+ (point)))
+
+ (when (<= end beg)
+ (setq beg line-beg)
+ (setq end line-end)
+ )
+ (when (= end beg)
+ (goto-char end)
+ (forward-line)
+ (setq end (point))
+ )
+ (if (> (flymake-get-line-err-count line-err-info-list "e") 0)
+ (setq face 'flymake-errline-face)
+ ;else
+ (setq face 'flymake-warnline-face)
+ )
+ (flymake-make-overlay beg end tooltip-text face nil)
+ )
+)
+
+(defun flymake-parse-err-lines(err-info-list source-buffer lines)
+ "parse err lines, store info in err-info-list"
+ (let* ((count (length lines))
+ (idx 0)
+ (line-err-info nil)
+ (real-file-name nil)
+ (source-file-name (buffer-file-name source-buffer))
+ (get-real-file-name-f (flymake-get-real-file-name-function source-file-name)))
+
+ (while (< idx count)
+ (setq line-err-info (flymake-parse-line (nth idx lines)))
+ (when line-err-info
+ (setq real-file-name (funcall get-real-file-name-f source-buffer (flymake-ler-get-file line-err-info)))
+ (setq line-err-info (flymake-ler-set-full-file line-err-info real-file-name))
+
+ (if (flymake-same-files real-file-name source-file-name)
+ (setq line-err-info (flymake-ler-set-file line-err-info nil))
+ ;else
+ (setq line-err-info (flymake-ler-set-file line-err-info (file-name-nondirectory real-file-name)))
+ )
+
+ (setq err-info-list (flymake-add-err-info err-info-list line-err-info))
+ )
+ (flymake-log 3 "parsed '%s', %s line-err-info" (nth idx lines) (if line-err-info "got" "no"))
+ (setq idx (1+ idx))
+ )
+ err-info-list
+ )
+)
+
+(defun flymake-split-output(output)
+ "split output into lines, return last one as residual if it does not end with newline char. Returns ((lines) residual)"
+ (when (and output (> (length output) 0))
+ (let* ((lines (flymake-split-string output "[\n\r]+"))
+ (complete (equal "\n" (char-to-string (aref output (1- (length output))))))
+ (residual nil))
+ (when (not complete)
+ (setq residual (car (last lines)))
+ (setq lines (butlast lines))
+ )
+ (list lines residual)
+ )
+ )
+)
+
+(eval-when-compile (require 'compile))
+(defvar flymake-err-line-patterns ; regexp file-idx line-idx col-idx (optional) text-idx(optional), match-end to end of string is error text
+ (append
+ '(
+ ; MS Visual C++ 6.0
+ ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)(\\([0-9]+\\)) \: \\(\\(error\\|warning\\|fatal error\\) \\(C[0-9]+\\):[ \t\n]*\\(.+\\)\\)"
+ 1 3 nil 4)
+ ; jikes
+ ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)\:\\([0-9]+\\)\:[0-9]+\:[0-9]+\:[0-9]+\: \\(\\(Error\\|Warning\\|Caution\\|Semantic Error\\):[ \t\n]*\\(.+\\)\\)"
+ 1 3 nil 4)
+ ; MS midl
+ ("midl[ ]*:[ ]*\\(command line error .*\\)"
+ nil nil nil 1)
+ ; MS C#
+ ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)(\\([0-9]+\\),[0-9]+)\: \\(\\(error\\|warning\\|fatal error\\) \\(CS[0-9]+\\):[ \t\n]*\\(.+\\)\\)"
+ 1 3 nil 4)
+ ; perl
+ ("\\(.*\\) at \\([^ \n]+\\) line \\([0-9]+\\)[,.\n]" 2 3 nil 1)
+ ; LaTeX warnings (fileless) ("\\(LaTeX \\(Warning\\|Error\\): .*\\) on input line \\([0-9]+\\)" 20 3 nil 1)
+ ; ant/javac
+ (" *\\(\\[javac\\]\\)? *\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)\:\\([0-9]+\\)\:[ \t\n]*\\(.+\\)"
+ 2 4 nil 5)
+ )
+ compilation-error-regexp-alist)
+ "patterns for matching error/warning lines, (regexp file-idx line-idx err-text-idx)"
+)
+;(defcustom flymake-err-line-patterns
+; '(
+; ; MS Visual C++ 6.0
+; ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)(\\([0-9]+\\)) \: \\(\\(error\\|warning\\|fatal error\\) \\(C[0-9]+\\):[ \t\n]*\\(.+\\)\\)"
+; 1 3 4)
+; ; jikes
+; ("\\(\\([a-zA-Z]:\\)?[^:(\t\n]+\\)\:\\([0-9]+\\)\:[0-9]+\:[0-9]+\:[0-9]+\: \\(\\(Error\\|Warning\\|Caution\\):[ \t\n]*\\(.+\\)\\)"
+; 1 3 4))
+; "patterns for matching error/warning lines, (regexp file-idx line-idx err-text-idx)"
+; :group 'flymake
+; :type '(repeat (string number number number))
+;)
+
+(defun flymake-parse-line(line)
+ "parse line to see whether it's an error of warning, return it's components or nil for no match"
+ (let ((raw-file-name nil)
+ (line-no 0)
+ (err-type "e")
+ (err-text nil)
+ (count (length flymake-err-line-patterns))
+ (idx 0)
+ (matched nil))
+ (while (and (< idx count) (not matched))
+ (when (string-match (car (nth idx flymake-err-line-patterns)) line)
+ (let* ((file-idx (nth 1 (nth idx flymake-err-line-patterns)))
+ (line-idx (nth 2 (nth idx flymake-err-line-patterns))))
+
+ (setq raw-file-name (if file-idx (match-string file-idx line) nil))
+ (setq line-no (if line-idx (string-to-int (match-string line-idx line)) 0))
+ (setq err-text (if (> (length (nth idx flymake-err-line-patterns)) 4)
+ (match-string (nth 4 (nth idx flymake-err-line-patterns)) line)
+ (flymake-patch-err-text (substring line (match-end 0)))))
+ (or err-text (setq err-text "<no error text>"))
+ (if (and err-text (string-match "^[wW]arning" err-text))
+ (setq err-type "w")
+ )
+ (flymake-log 3 "parse line: file-idx=%s line-idx=%s file=%s line=%s text=%s" file-idx line-idx
+ raw-file-name line-no err-text)
+ (setq matched t)
+ )
+ )
+ (setq idx (1+ idx))
+ )
+ (if matched
+ (flymake-ler-make-ler raw-file-name line-no err-type err-text)
+ ; else
+ ()
+ )
+ )
+)
+
+(defun flymake-find-err-info(err-info-list line-no)
+ "find (line-err-info-list pos) for specified line-no"
+ (if err-info-list
+ (let* ((line-err-info-list nil)
+ (pos 0)
+ (count (length err-info-list)))
+
+ (while (and (< pos count) (< (car (nth pos err-info-list)) line-no))
+ (setq pos (1+ pos))
+ )
+ (when (and (< pos count) (equal (car (nth pos err-info-list)) line-no))
+ (setq line-err-info-list (flymake-er-get-line-err-info-list (nth pos err-info-list)))
+ )
+ (list line-err-info-list pos)
+ )
+ ;else
+ '(nil 0)
+ )
+)
+
+(defun flymake-line-err-info-is-less-or-equal(line-one line-two)
+ (or (string< (flymake-ler-get-type line-one) (flymake-ler-get-type line-two))
+ (and (string= (flymake-ler-get-type line-one) (flymake-ler-get-type line-two))
+ (not (flymake-ler-get-file line-one)) (flymake-ler-get-file line-two)
+ )
+ (and (string= (flymake-ler-get-type line-one) (flymake-ler-get-type line-two))
+ (or (and (flymake-ler-get-file line-one) (flymake-ler-get-file line-two))
+ (and (not (flymake-ler-get-file line-one)) (not (flymake-ler-get-file line-two)))
+ )
+ )
+ )
+)
+
+(defun flymake-add-line-err-info(line-err-info-list line-err-info)
+ "insert new err info favoring sorting: err-type e/w, filename nil/non-nill"
+ (if (not line-err-info-list)
+ (list line-err-info)
+ ;else
+ (let* ((count (length line-err-info-list))
+ (idx 0))
+ (while (and (< idx count) (flymake-line-err-info-is-less-or-equal (nth idx line-err-info-list) line-err-info))
+ (setq idx (1+ idx))
+ )
+ (cond ((equal 0 idx) (setq line-err-info-list (cons line-err-info line-err-info-list)))
+ (t (setq line-err-info-list (flymake-ins-after line-err-info-list (1- idx) line-err-info)))
+ )
+ line-err-info-list
+ )
+ )
+)
+
+(defun flymake-add-err-info(err-info-list line-err-info)
+ "add error info (file line type text) to err info list preserving sort order"
+ (let* ((count (length err-info-list))
+ (line-no (if (flymake-ler-get-file line-err-info) 1 (flymake-ler-get-line line-err-info)))
+ (info-and-pos (flymake-find-err-info err-info-list line-no))
+ (exists (car info-and-pos))
+ (pos (nth 1 info-and-pos))
+ (line-err-info-list nil)
+ (err-info nil))
+
+ (if exists
+ (setq line-err-info-list (flymake-er-get-line-err-info-list (car (nthcdr pos err-info-list))))
+ )
+ (setq line-err-info-list (flymake-add-line-err-info line-err-info-list line-err-info))
+
+ (setq err-info (flymake-er-make-er line-no line-err-info-list))
+ (cond (exists (setq err-info-list (flymake-set-at err-info-list pos err-info)))
+ ((equal 0 pos) (setq err-info-list (cons err-info err-info-list)))
+ (t (setq err-info-list (flymake-ins-after err-info-list (1- pos) err-info)))
+ )
+ err-info-list
+ )
+)
+
+(defun flymake-get-project-include-dirs-imp(basedir)
+ "include dirs for the project current file belongs to"
+ (if (flymake-get-project-include-dirs-from-cache basedir)
+ (progn
+ (flymake-get-project-include-dirs-from-cache basedir)
+ )
+ ;else
+ (let* ((command-line (concat "make -C\"" basedir "\" DUMPVARS=INCLUDE_DIRS dumpvars"))
+ (output (shell-command-to-string command-line))
+ (lines (flymake-split-string output "\n"))
+ (count (length lines))
+ (idx 0)
+ (inc-dirs nil))
+ (while (and (< idx count) (not (string-match "^INCLUDE_DIRS=.*" (nth idx lines))))
+ (setq idx (1+ idx))
+ )
+ (when (< idx count)
+ (let* ((inc-lines (flymake-split-string (nth idx lines) " *-I"))
+ (inc-count (length inc-lines)))
+ (while (> inc-count 0)
+ (when (not (string-match "^INCLUDE_DIRS=.*" (nth (1- inc-count) inc-lines)))
+ (setq inc-dirs (cons (flymake-replace-regexp-in-string "\"" "" (nth (1- inc-count) inc-lines)) inc-dirs))
+ )
+ (setq inc-count (1- inc-count))
+ )
+ )
+ )
+ (flymake-add-project-include-dirs-to-cache basedir inc-dirs)
+ inc-dirs
+ )
+ )
+)
+
+(defcustom flymake-get-project-include-dirs-function 'flymake-get-project-include-dirs-imp
+ "function used to get project inc dirs, one paramater: basedir name"
+ :group 'flymake
+ :type 'function
+)
+
+(defun flymake-get-project-include-dirs(basedir)
+ (funcall flymake-get-project-include-dirs-function basedir)
+)
+
+(defun flymake-get-system-include-dirs()
+ "system include dirs - from the 'INCLUDE' env setting"
+ (let* ((includes (getenv "INCLUDE")))
+ (if includes (flymake-split-string includes path-separator) nil)
+ )
+)
+
+(defvar flymake-project-include-dirs-cache (flymake-makehash 'equal))
+(defun flymake-get-project-include-dirs-from-cache(base-dir)
+ (gethash base-dir flymake-project-include-dirs-cache)
+)
+(defun flymake-add-project-include-dirs-to-cache(base-dir include-dirs)
+ (puthash base-dir include-dirs flymake-project-include-dirs-cache)
+)
+(defun flymake-clear-project-include-dirs-cache()
+ (clrhash flymake-project-include-dirs-cache)
+)
+
+(defun flymake-get-include-dirs(base-dir)
+ "dirs to use when resolving local filenames"
+ (let* ((include-dirs (append '(".") (flymake-get-project-include-dirs base-dir) (flymake-get-system-include-dirs))))
+ include-dirs
+ )
+)
+
+(defun flymake-find-file(rel-file-name include-dirs)
+ "iterate through include-dirs, return first 'include-dir/rel-file-name' that exists, or just rel-file-name if not"
+ (let* ((count (length include-dirs))
+ (idx 0)
+ (found nil)
+ (full-file-name rel-file-name))
+
+ (while (and (not found) (< idx count))
+ (let* ((dir (nth idx include-dirs)))
+ (setq full-file-name (concat dir "/" rel-file-name))
+ (when (file-exists-p full-file-name)
+ (setq done t)
+ )
+ )
+ (setq idx (1+ idx))
+ )
+ (if found
+ full-file-name
+ ;else
+ rel-file-name
+ )
+ )
+)
+
+(defun flymake-restore-formatting(source-buffer)
+ "Remove any formatting made by flymake"
+)
+
+(defun flymake-get-program-dir(buffer)
+ "dir to start profram in"
+ (unless (bufferp buffer)
+ (error "invlid buffer")
+ )
+ (save-excursion
+ (set-buffer buffer)
+ default-directory
+ )
+)
+
+(defun flymake-safe-delete-file(file-name)
+ (when (and file-name (file-exists-p file-name))
+ (delete-file file-name)
+ (flymake-log 1 "deleted file %s" file-name)
+ )
+)
+
+(defun flymake-safe-delete-directory(dir-name)
+ (condition-case err
+ (progn
+ (delete-directory dir-name)
+ (flymake-log 1 "deleted dir %s" dir-name)
+ )
+ (error
+ (flymake-log 1 "failed to delete dir %s, error ignored" dir-name)
+ )
+ )
+)
+
+(defcustom flymake-compilation-prevents-syntax-check t
+ "if non-nil, syntax check won't be started in case compilation is running"
+ :group 'flymake
+ :type 'boolean
+)
+
+(defun flymake-start-syntax-check(buffer)
+ "start syntax checking for buffer"
+ (unless (bufferp buffer)
+ (error "expected a buffer")
+ )
+ (save-excursion
+ (set-buffer buffer)
+ (flymake-log 3 "flymake is running: %s" (flymake-get-buffer-is-running buffer))
+ (when (and (not (flymake-get-buffer-is-running buffer))
+ (flymake-can-syntax-check-file (buffer-file-name buffer)))
+ (when (or (not flymake-compilation-prevents-syntax-check)
+ (not (flymake-compilation-is-running))) ;+ (flymake-rep-ort-status buffer "COMP")
+ (flymake-clear-buildfile-cache)
+ (flymake-clear-project-include-dirs-cache)
+
+ (flymake-set-buffer-check-was-interrupted buffer nil)
+ (flymake-set-buffer-data buffer (flymake-makehash 'equal))
+
+ (let* ((source-file-name (buffer-file-name buffer))
+ (init-f (flymake-get-init-function source-file-name))
+ (cleanup-f (flymake-get-cleanup-function source-file-name))
+ (cmd-and-args (funcall init-f buffer))
+ (cmd (nth 0 cmd-and-args))
+ (args (nth 1 cmd-and-args))
+ (dir (nth 2 cmd-and-args)))
+ (if (not cmd-and-args)
+ (progn
+ (flymake-log 0 "init function %s for %s failed, cleaning up" init-f source-file-name)
+ (funcall cleanup-f buffer)
+ )
+ ;else
+ (progn
+ (flymake-set-buffer-last-change-time buffer nil)
+ (flymake-start-syntax-check-process buffer cmd args dir)
+ )
+ )
+ )
+ )
+ )
+ )
+)
+
+(defun flymake-start-syntax-check-process(buffer cmd args dir)
+ "start syntax check-process"
+
+ (let* ((process nil))
+ (condition-case err
+ (progn
+ (when dir
+ (let ((default-directory dir))
+ (flymake-log 3 "starting process on dir %s" default-directory)
+ )
+ )
+ (setq process (get-process (apply 'start-process "flymake-proc" nil cmd args)))
+ (set-process-sentinel process 'flymake-process-sentinel)
+ (set-process-filter process 'flymake-process-filter)
+
+ (flymake-reg-names (process-id process) (buffer-name buffer))
+
+ (flymake-set-buffer-is-running buffer t)
+ (flymake-set-buffer-last-change-time buffer nil)
+ (flymake-set-buffer-check-start-time buffer (flymake-float-time))
+
+ (flymake-report-status buffer nil "*")
+ (flymake-log 2 "started process %d, command=%s, dir=%s"
+ (process-id process) (process-command process) default-directory)
+ process
+ )
+ (error
+ (let ((err-str (format "Failed to launch syntax check process '%s' with args %s: %s"
+ cmd args (error-message-string err)))
+ (source-file-name (buffer-file-name buffer))
+ (cleanup-f (flymake-get-cleanup-function source-file-name)))
+ (flymake-log 0 err-str)
+ (funcall cleanup-f buffer)
+ (flymake-report-fatal-status buffer "PROCERR" err-str)
+ )
+ )
+ )
+ )
+)
+
+(defun flymake-kill-process(pid &optional rest)
+ "kill process pid"
+ (signal-process pid 9)
+ (let* ((buffer-name (flymake-get-source-buffer-name pid)))
+ (when (and buffer-name (get-buffer buffer-name))
+ (flymake-set-buffer-check-was-interrupted (get-buffer buffer-name) t)
+ )
+ )
+ (flymake-log 1 "killed process %d" pid)
+)
+
+(defun flymake-stop-all-syntax-checks()
+ "kill all syntax check processes"
+ (interactive)
+ (let ((pids (copy-hash-table flymake-pid-to-names)))
+ (maphash 'flymake-kill-process pids)
+ )
+)
+
+(defun flymake-compilation-is-running()
+ (and (boundp 'compilation-in-progress)
+ compilation-in-progress)
+)
+
+(defun flymake-compile()
+ "kill all flymake syntax checks, start compilation"
+ (interactive)
+ (flymake-stop-all-syntax-checks)
+ (call-interactively 'compile)
+)
+
+(defvar flymake-is-running nil
+ "t if flymake syntax check process is running for the current buffer"
+)
+(make-variable-buffer-local 'flymake-is-running)
+(defun flymake-get-buffer-is-running(buffer)
+ (flymake-get-buffer-var buffer 'flymake-is-running)
+)
+(defun flymake-set-buffer-is-running(buffer is-running)
+ (flymake-set-buffer-var buffer 'flymake-is-running is-running)
+)
+
+(defvar flymake-timer nil
+ "timer for starting syntax checks"
+)
+(make-variable-buffer-local 'flymake-timer)
+(defun flymake-get-buffer-timer(buffer)
+ (flymake-get-buffer-var buffer 'flymake-timer)
+)
+(defun flymake-set-buffer-timer(buffer timer)
+ (flymake-set-buffer-var buffer 'flymake-timer timer)
+)
+
+(defvar flymake-last-change-time nil
+ "time of last buffer change"
+)
+(make-variable-buffer-local 'flymake-last-change-time)
+(defun flymake-get-buffer-last-change-time(buffer)
+ (flymake-get-buffer-var buffer 'flymake-last-change-time)
+)
+(defun flymake-set-buffer-last-change-time(buffer change-time)
+ (flymake-set-buffer-var buffer 'flymake-last-change-time change-time)
+)
+
+(defvar flymake-check-start-time nil
+ "time at which syntax check was started")
+(make-variable-buffer-local 'flymake-check-start-time)
+(defun flymake-get-buffer-check-start-time(buffer)
+ (flymake-get-buffer-var buffer 'flymake-check-start-time)
+)
+(defun flymake-set-buffer-check-start-time(buffer check-start-time)
+ (flymake-set-buffer-var buffer 'flymake-check-start-time check-start-time)
+)
+
+(defvar flymake-check-was-interrupted nil
+ "t if syntax check was killed by flymake-compile"
+)
+(make-variable-buffer-local 'flymake-check-was-interrupted)
+(defun flymake-get-buffer-check-was-interrupted(buffer)
+ (flymake-get-buffer-var buffer 'flymake-check-was-interrupted)
+)
+(defun flymake-set-buffer-check-was-interrupted(buffer interrupted)
+ (flymake-set-buffer-var buffer 'flymake-check-was-interrupted interrupted)
+)
+
+(defcustom flymake-no-changes-timeout 0.5
+ "time to wait after last change before starting compilation"
+ :group 'flymake
+ :type 'number
+)
+
+(defun flymake-on-timer-event(buffer)
+ "start a syntax check for buffer if necessary"
+ ;+(flymake-log 3 "timer: running=%s, time=%s, cur-time=%s" (flymake-get-buffer-is-running buffer) (flymake-get-buffer-last-change-time buffer) (flymake-float-time))
+
+ (when (and (bufferp buffer) (not (flymake-get-buffer-is-running buffer)))
+ (save-excursion
+ (set-buffer buffer)
+ (when (and (flymake-get-buffer-last-change-time buffer)
+ (> (flymake-float-time) (+ flymake-no-changes-timeout (flymake-get-buffer-last-change-time buffer))))
+ (flymake-set-buffer-last-change-time buffer nil)
+ (flymake-log 3 "starting syntax check as more than 1 second passed since last change")
+ (flymake-start-syntax-check buffer)
+ )
+ )
+ )
+)
+
+(defun flymake-start-syntax-check-for-current-buffer()
+ "run flymake-start-syntax-check for current buffer if it isn't already running"
+ (interactive)
+ (flymake-start-syntax-check (current-buffer))
+)
+
+(defun flymake-current-line-no()
+ "return number of current line in current buffer"
+ (interactive)
+ (let ((beg (point-min))
+ (end (if (= (point) (point-max)) (point) (1+ (point)))))
+ (count-lines beg end)
+ )
+)
+
+(defun flymake-get-line-count(buffer)
+ "return number of lines in buffer"
+ (unless (bufferp buffer)
+ (error "invalid buffer")
+ )
+ (save-excursion
+ (set-buffer buffer)
+ (count-lines (point-min) (point-max))
+ )
+)
+
+(defun flymake-count-lines(buffer)
+ "return number of lines in buffer"
+ (save-excursion
+ (set-buffer buffer)
+ (count-lines (point-min) (point-max))
+ )
+)
+
+(defun flymake-get-point-pixel-pos()
+ "return point position in pixels: (x, y)"
+ (let ((mouse-pos (mouse-position))
+ (pixel-pos nil)
+ (ret nil))
+ (if (car (cdr mouse-pos))
+ (progn
+ (set-mouse-position (flymake-selected-frame) (current-column) (flymake-current-row))
+ (setq pixel-pos (mouse-pixel-position))
+ (set-mouse-position (car mouse-pos) (car (cdr mouse-pos)) (cdr (cdr mouse-pos)))
+ (setq ret (list (car (cdr pixel-pos)) (cdr (cdr pixel-pos))))
+ )
+ ;else
+ (progn
+ (setq ret '(0 0))
+ )
+ )
+ (flymake-log 3 "mouse pos is %s" ret)
+ ret
+ )
+)
+
+(defun flymake-display-err-menu-for-current-line()
+ "Display a menu with errors/warnings for current line if it has errors and/or warnings"
+ (interactive)
+ (let* ((line-no (flymake-current-line-no))
+ (line-err-info-list (nth 0 (flymake-find-err-info (flymake-get-buffer-err-info (current-buffer)) line-no)))
+ (menu-data (flymake-make-err-menu-data line-no line-err-info-list))
+ (choice nil)
+ (mouse-pos (flymake-get-point-pixel-pos))
+ (moved-mouse-pos (list (car mouse-pos) (+ 10 (car (cdr mouse-pos)))))
+ (menu-pos (list (flymake-get-point-pixel-pos) (selected-window))))
+ (if menu-data
+ (progn
+ (setq choice (flymake-popup-menu menu-pos menu-data))
+ (flymake-log 3 "choice=%s" choice)
+ (when choice
+ (eval choice)
+ )
+ )
+ ;else
+ (flymake-log 1 "no errors for line %d" line-no)
+ )
+ )
+)
+
+(defun flymake-make-err-menu-data(line-no line-err-info-list)
+ "Make a (menu-title (item-title item-action)*) list with errors/warnings from line-err-info"
+ (let* ((menu-items nil))
+ (when line-err-info-list
+ (let* ((count (length line-err-info-list))
+ (menu-item-text nil))
+ (while (> count 0)
+ (setq menu-item-text (flymake-ler-get-text (nth (1- count) line-err-info-list)))
+ (let* ((file (flymake-ler-get-file (nth (1- count) line-err-info-list)))
+ (full-file (flymake-ler-get-full-file (nth (1- count) line-err-info-list)))
+ (line (flymake-ler-get-line (nth (1- count) line-err-info-list))))
+ (if file
+ (setq menu-item-text (concat menu-item-text " - " file "(" (format "%d" line) ")"))
+ )
+ (setq menu-items (cons (list menu-item-text
+ (if file (list 'flymake-goto-file-and-line full-file line) nil))
+ menu-items))
+ )
+ (setq count (1- count))
+ )
+ (flymake-log 3 "created menu-items with %d item(s)" (length menu-items))
+ )
+ )
+ (if menu-items
+ (let* ((menu-title (format "Line %d: %d error(s), %d warning(s)" line-no
+ (flymake-get-line-err-count line-err-info-list "e")
+ (flymake-get-line-err-count line-err-info-list "w"))))
+ (list menu-title menu-items)
+ )
+ ;else
+ nil
+ )
+ )
+)
+
+(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)
+ ;else
+ (progn
+ (find-file file)
+ (goto-line line)
+ )
+ )
+)
+;; flymake minor mode declarations
+
+(defvar flymake-mode nil)
+(make-variable-buffer-local 'flymake-mode)
+
+(defvar flymake-mode-line nil
+ ""
+)
+(make-variable-buffer-local 'flymake-mode-line)
+(defun flymake-get-buffer-mode-line(buffer)
+ (flymake-get-buffer-var buffer 'flymake-mode-line)
+)
+(defun flymake-set-buffer-mode-line(buffer mode-line-string)
+ (flymake-set-buffer-var buffer 'flymake-mode-line mode-line-string)
+)
+
+(defvar flymake-mode-line-e-w nil)
+(make-variable-buffer-local 'flymake-mode-line-e-w)
+(defun flymake-get-buffer-mode-line-e-w(buffer)
+ (flymake-get-buffer-var buffer 'flymake-mode-line-e-w)
+)
+(defun flymake-set-buffer-mode-line-e-w(buffer e-w)
+ (flymake-set-buffer-var buffer 'flymake-mode-line-e-w e-w)
+)
+
+(defvar flymake-mode-line-status nil)
+(make-variable-buffer-local 'flymake-mode-line-status)
+(defun flymake-get-buffer-mode-line-status(buffer)
+ (flymake-get-buffer-var buffer 'flymake-mode-line-status)
+)
+(defun flymake-set-buffer-mode-line-status(buffer status)
+ (flymake-set-buffer-var buffer 'flymake-mode-line-status status)
+)
+
+(defun flymake-report-status(buffer e-w &optional status)
+ "show status in the mode line"
+ (when (bufferp buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (when e-w
+ (flymake-set-buffer-mode-line-e-w buffer e-w)
+ )
+ (when status
+ (flymake-set-buffer-mode-line-status buffer status)
+ )
+ (let* ((mode-line " Flymake"))
+ (when (> (length (flymake-get-buffer-mode-line-e-w buffer)) 0)
+ (setq mode-line (concat mode-line ":" (flymake-get-buffer-mode-line-e-w buffer)))
+ )
+ (setq mode-line (concat mode-line (flymake-get-buffer-mode-line-status buffer)))
+ (flymake-set-buffer-mode-line buffer mode-line)
+ (force-mode-line-update)
+ )
+ )
+ )
+)
+
+(defun flymake-display-warning(warning)
+ "display a warning to the user"
+ (message-box warning)
+)
+
+(defcustom flymake-gui-warnings-enabled t
+ "enables/disables gui warnings"
+ :group 'flymake
+ :type 'boolean
+)
+
+(defun flymake-report-fatal-status(buffer status warning)
+ "display a warning and switch flymake mode OFF"
+ (when flymake-gui-warnings-enabled
+ (flymake-display-warning (format "Flymake: %s. Flymake will be switched OFF" warning))
+ )
+ (save-excursion
+ (set-buffer buffer)
+ (flymake-mode 0)
+ (flymake-log 0 "switched OFF Flymake mode for buffer %s due to fatal status %s, warning %s"
+ (buffer-name buffer) status warning)
+ )
+)
+
+(defun flymake-mode(&optional arg)
+ "toggle flymake-mode"
+ (interactive)
+ (let ((old-flymake-mode flymake-mode))
+
+ (setq turn-on
+ (if (null arg)
+ (not flymake-mode)
+ ;else
+ (> (prefix-numeric-value arg) 0))
+ )
+
+ (if turn-on
+ (if (flymake-can-syntax-check-file (buffer-file-name))
+ (flymake-mode-on)
+ ;else
+ (flymake-log 2 "flymake cannot check syntax in buffer %s" (buffer-name))
+ )
+ ;else
+ (flymake-mode-off)
+ )
+ (force-mode-line-update)
+ )
+)
+
+;;;###autoload
+(unless (assq 'flymake-mode minor-mode-alist)
+ (setq minor-mode-alist (cons '(flymake-mode flymake-mode-line) minor-mode-alist))
+)
+
+;;;###autoload
+(defun flymake-mode-on()
+ "turn flymake mode on"
+ (when (not flymake-mode)
+ (make-local-variable 'after-change-functions)
+ (setq after-change-functions (cons 'flymake-after-change-function after-change-functions))
+ (add-hook 'after-save-hook 'flymake-after-save-hook)
+ (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook)
+ ;+(add-hook 'find-file-hooks 'flymake-find-file-hook)
+
+ (flymake-report-status (current-buffer) "" "")
+
+ (flymake-set-buffer-timer (current-buffer) (run-at-time nil 1 'flymake-on-timer-event (current-buffer)))
+
+ (setq flymake-mode t)
+ (flymake-log 1 "flymake mode turned ON for buffer %s" (buffer-name (current-buffer)))
+ (when flymake-start-syntax-check-on-find-file
+ (flymake-start-syntax-check-for-current-buffer) ; will be started by on-load hook
+ )
+ )
+)
+
+;;;###autoload
+(defun flymake-mode-off()
+ "turn flymake mode off"
+ (when flymake-mode
+ (setq after-change-functions (delq 'flymake-after-change-function after-change-functions))
+ (remove-hook 'after-save-hook (function flymake-after-save-hook) t)
+ (remove-hook 'kill-buffer-hook (function flymake-kill-buffer-hook) t)
+ ;+(remove-hook 'find-file-hooks (function flymake-find-file-hook) t)
+
+ (flymake-delete-own-overlays (current-buffer))
+
+ (when (flymake-get-buffer-timer (current-buffer))
+ (cancel-timer (flymake-get-buffer-timer (current-buffer)))
+ (flymake-set-buffer-timer (current-buffer) nil)
+ )
+
+ (flymake-set-buffer-is-running (current-buffer) nil)
+
+ (setq flymake-mode nil)
+ (flymake-log 1 "flymake mode turned OFF for buffer %s" (buffer-name (current-buffer)))
+ )
+)
+
+(defcustom flymake-start-syntax-check-on-newline t
+ "start syntax check if newline char was added/removed from the buffer"
+ :group 'flymake
+ :type 'boolean
+)
+
+(defun flymake-after-change-function(start stop len)
+ "Start syntax check for current buffer if it isn't already running"
+ ;+(flymake-log 0 "setting change time to %s" (flymake-float-time))
+ (let((new-text (buffer-substring start stop)))
+ (when (and flymake-start-syntax-check-on-newline (equal new-text "\n"))
+ (flymake-log 3 "starting syntax check as new-line has been seen")
+ (flymake-start-syntax-check-for-current-buffer)
+ )
+ (flymake-set-buffer-last-change-time (current-buffer) (flymake-float-time))
+ )
+)
+
+(defun flymake-after-save-hook()
+ (if (local-variable-p 'flymake-mode (current-buffer)) ; (???) other way to determine whether flymake is active in buffer being saved?
+ (progn
+ (flymake-log 3 "starting syntax check as buffer was saved")
+ (flymake-start-syntax-check-for-current-buffer) ; no more mode 3. cannot start check if mode 3 (to temp copies) is active - (???)
+ )
+ )
+)
+
+(defun flymake-kill-buffer-hook()
+ (when (flymake-get-buffer-timer (current-buffer))
+ (cancel-timer (flymake-get-buffer-timer (current-buffer)))
+ (flymake-set-buffer-timer (current-buffer) nil)
+ )
+)
+
+(defcustom flymake-start-syntax-check-on-find-file t
+ "statr syntax check on find file"
+ :group 'flymake
+ :type 'boolean
+)
+
+(defun flymake-find-file-hook()
+ ;+(when flymake-start-syntax-check-on-find-file
+ ;+ (flymake-log 3 "starting syntax check on file open")
+ ;+ (flymake-start-syntax-check-for-current-buffer)
+ ;+)
+ (when (and (not (local-variable-p 'flymake-mode (current-buffer)))
+ (flymake-can-syntax-check-file (buffer-file-name (current-buffer))))
+ (flymake-mode)
+ (flymake-log 3 "automatically turned ON flymake mode")
+ )
+)
+
+(defun flymake-get-first-err-line-no(err-info-list)
+ "return first line-no with error"
+ (when err-info-list
+ (flymake-er-get-line (car err-info-list))
+ )
+)
+
+(defun flymake-get-last-err-line-no(err-info-list)
+ "return last line-no with error"
+ (when err-info-list
+ (flymake-er-get-line (nth (1- (length err-info-list)) err-info-list))
+ )
+)
+
+(defun flymake-get-next-err-line-no(err-info-list line-no)
+ "return next line with erroe"
+ (when err-info-list
+ (let* ((count (length err-info-list))
+ (idx 0))
+ (while (and (< idx count) (>= line-no (flymake-er-get-line (nth idx err-info-list))))
+ (setq idx (1+ idx))
+ )
+ (if (< idx count)
+ (flymake-er-get-line (nth idx err-info-list))
+ )
+ )
+ )
+)
+
+(defun flymake-get-prev-err-line-no(err-info-list line-no)
+ "return prev line with error"
+ (when err-info-list
+ (let* ((count (length err-info-list)))
+ (while (and (> count 0) (<= line-no (flymake-er-get-line (nth (1- count) err-info-list))))
+ (setq count (1- count))
+ )
+ (if (> count 0)
+ (flymake-er-get-line (nth (1- count) err-info-list))
+ )
+ )
+ )
+)
+
+(defun flymake-skip-whitespace()
+ "move forward until nonwhitespace is reached"
+ (while (looking-at "[ \t]")
+ (forward-char)
+ )
+)
+
+(defun flymake-goto-line(line-no)
+ "goto-line, then skip whitespace"
+ (goto-line line-no)
+ (flymake-skip-whitespace)
+)
+
+(defun flymake-goto-next-error()
+ "go to next error in err ring"
+ (interactive)
+ (let ((line-no (flymake-get-next-err-line-no (flymake-get-buffer-err-info (current-buffer)) (flymake-current-line-no))))
+ (when (not line-no)
+ (setq line-no (flymake-get-first-err-line-no (flymake-get-buffer-err-info (current-buffer))))
+ (flymake-log 1 "passed end of file")
+ )
+ (if line-no
+ (flymake-goto-line line-no)
+ ;else
+ (flymake-log 1 "no errors in current buffer")
+ )
+ )
+)
+
+(defun flymake-goto-prev-error()
+ "go to prev error in err ring"
+ (interactive)
+ (let ((line-no (flymake-get-prev-err-line-no (flymake-get-buffer-err-info (current-buffer)) (flymake-current-line-no))))
+ (when (not line-no)
+ (setq line-no (flymake-get-last-err-line-no (flymake-get-buffer-err-info (current-buffer))))
+ (flymake-log 1 "passed beginning of file")
+ )
+ (if line-no
+ (flymake-goto-line line-no)
+ ;else
+ (flymake-log 1 "no errors in current buffer")
+ )
+ )
+)
+
+(defun flymake-patch-err-text(string)
+ (if (string-match "^[\n\t :0-9]*\\(.*\\)$" string)
+ (match-string 1 string)
+ ;else
+ string
+ )
+)
+
+;;;; general init-cleanup and helper routines
+
+(defun flymake-create-temp-inplace(file-name prefix)
+ (unless (stringp file-name)
+ (error "invalid file-name")
+ )
+ (or prefix
+ (setq prefix "flymake")
+ )
+ (let* ((temp-name (concat (file-name-sans-extension file-name)
+ "_" prefix
+ (and (file-name-extension file-name)
+ (concat "." (file-name-extension file-name))))))
+ (flymake-log 3 "create-temp-inplace: file=%s temp=%s" file-name temp-name)
+ temp-name
+ )
+)
+
+(defun flymake-create-temp-with-folder-structure(file-name prefix)
+ (unless (stringp file-name)
+ (error "invalid file-name")
+ )
+
+ (let* ((dir (file-name-directory file-name))
+ (slash-pos (string-match "/" dir))
+ (temp-dir (concat (flymake-ensure-ends-with-slash (flymake-get-temp-dir)) (substring dir (1+ slash-pos)))))
+
+ (file-truename (concat (flymake-ensure-ends-with-slash temp-dir)
+ (file-name-nondirectory file-name)))
+ )
+)
+
+(defun flymake-strrchr(str ch)
+ (let* ((count (length str))
+ (pos nil))
+ (while (and (not pos) (> count 0))
+ (if (= ch (elt str (1- count)))
+ (setq pos (1- count))
+ )
+ (setq count (1- count))
+ )
+ pos
+ )
+)
+
+(defun flymake-delete-temp-directory(dir-name)
+ "attempt to delete temp dir created by flymake-create-temp-with-folder-structure, do not fail on error"
+ (let* ((temp-dir (flymake-get-temp-dir))
+ (suffix (substring dir-name (1+ (length temp-dir))))
+ (slash-pos nil))
+
+ (while (> (length suffix) 0)
+ ;+(flymake-log 0 "suffix=%s" suffix)
+ (flymake-safe-delete-directory (file-truename (concat (flymake-ensure-ends-with-slash temp-dir) suffix)))
+ (setq slash-pos (flymake-strrchr suffix (string-to-char "/")))
+ (if slash-pos
+ (setq suffix (substring suffix 0 slash-pos))
+ ;else
+ (setq suffix "")
+ )
+ )
+ )
+)
+
+(defun flymake-init-create-temp-buffer-copy(buffer create-temp-f)
+ "make a temporary copy of the current buffer, save its name in buffer data and return the name"
+ (let* ((source-file-name (buffer-file-name buffer))
+ (temp-source-file-name (funcall create-temp-f source-file-name "flymake")))
+
+ (flymake-save-buffer-in-file buffer temp-source-file-name)
+ (flymake-set-buffer-value buffer "temp-source-file-name" temp-source-file-name)
+
+ temp-source-file-name
+ )
+)
+
+(defun flymake-simple-cleanup(buffer)
+ "cleanup after flymake-init-create-temp-buffer-copy -- delete temp file"
+ (let* ((temp-source-file-name (flymake-get-buffer-value buffer "temp-source-file-name")))
+ (flymake-safe-delete-file temp-source-file-name)
+ (flymake-set-buffer-last-change-time buffer nil)
+ )
+)
+
+(defun flymake-get-real-file-name(buffer file-name-from-err-msg)
+ "Translate file name from error message to `real' file name. Return full-name. Names are real, not patched"
+ (let* ((real-name nil)
+ (source-file-name (buffer-file-name buffer))
+ (master-file-name (flymake-get-buffer-value buffer "master-file-name"))
+ (temp-source-file-name (flymake-get-buffer-value buffer "temp-source-file-name"))
+ (temp-master-file-name (flymake-get-buffer-value buffer "temp-master-file-name"))
+ (base-dirs (list (flymake-get-buffer-value buffer "base-dir")
+ (file-name-directory source-file-name)
+ (if master-file-name (file-name-directory master-file-name) nil)))
+ (files (list (list source-file-name source-file-name)
+ (list temp-source-file-name source-file-name)
+ (list master-file-name master-file-name)
+ (list temp-master-file-name master-file-name))))
+
+ (when (equal 0 (length file-name-from-err-msg))
+ (setq file-name-from-err-msg source-file-name)
+ )
+
+ (setq real-name (flymake-get-full-patched-file-name file-name-from-err-msg base-dirs files))
+ ; if real-name is nil, than file name from err msg is none of the files we've patched
+ (if (not real-name)
+ (setq real-name (flymake-get-full-nonpatched-file-name file-name-from-err-msg base-dirs))
+ )
+ (if (not real-name)
+ (setq real-name file-name-from-err-msg)
+ )
+ (setq real-name (flymake-fix-path-name real-name))
+ (flymake-log 3 "get-real-file-name: file-name=%s real-name=%s" file-name-from-err-msg real-name)
+ real-name
+ )
+)
+
+(defun flymake-get-full-patched-file-name(file-name-from-err-msg base-dirs files)
+ (let* ((base-dirs-count (length base-dirs))
+ (file-count (length files))
+ (real-name nil))
+
+ (while (and (not real-name) (> base-dirs-count 0))
+ (setq file-count (length files))
+ (while (and (not real-name) (> file-count 0))
+ (let* ((this-dir (nth (1- base-dirs-count) base-dirs))
+ (this-file (nth 0 (nth (1- file-count) files)))
+ (this-real-name (nth 1 (nth (1- file-count) files))))
+ ;+(flymake-log 0 "this-dir=%s this-file=%s this-real=%s msg-file=%s" this-dir this-file this-real-name file-name-from-err-msg)
+ (when (and this-dir this-file (flymake-same-files
+ (flymake-get-absolute-file-name-basedir file-name-from-err-msg this-dir)
+ this-file))
+ (setq real-name this-real-name)
+ )
+ )
+ (setq file-count (1- file-count))
+ )
+ (setq base-dirs-count (1- base-dirs-count))
+ )
+ real-name
+ )
+)
+
+(defun flymake-get-full-nonpatched-file-name(file-name-from-err-msg base-dirs)
+ (let* ((real-name nil))
+ (if (file-name-absolute-p file-name-from-err-msg)
+ (setq real-name file-name-from-err-msg)
+ ;else
+ (let* ((base-dirs-count (length base-dirs)))
+ (while (and (not real-name) (> base-dirs-count 0))
+ (let* ((full-name (flymake-get-absolute-file-name-basedir file-name-from-err-msg
+ (nth (1- base-dirs-count) base-dirs))))
+ (if (file-exists-p full-name)
+ (setq real-name full-name)
+ )
+ (setq base-dirs-count (1- base-dirs-count))
+ )
+ )
+ )
+ )
+ real-name
+ )
+)
+
+(defun flymake-get-absolute-file-name-basedir(file-name dir-name)
+ (if (file-name-absolute-p file-name)
+ file-name
+ ;else
+ (concat dir-name "/" file-name)
+ )
+)
+
+(defun flymake-init-find-buildfile-dir(buffer source-file-name buildfile-name)
+ "find buildfile, store its dir in buffer data and return its dir, if found"
+ (let* ((buildfile-dir (flymake-find-buildfile buildfile-name
+ (file-name-directory source-file-name)
+ flymake-buildfile-dirs)))
+ (if (not buildfile-dir)
+ (progn
+ (flymake-log 1 "no buildfile (%s) for %s" buildfile-name source-file-name)
+ (flymake-report-fatal-status buffer "NOMK" (format "No buildfile (%s) found for %s" buildfile-name source-file-name))
+ )
+ ;else
+ (progn
+ (flymake-set-buffer-value buffer "base-dir" buildfile-dir)
+ )
+ )
+ buildfile-dir
+ )
+)
+
+(defun flymake-init-create-temp-source-and-master-buffer-copy(buffer get-incl-dirs-f create-temp-f master-file-masks include-regexp-list)
+ "find master file (or buffer), create it's copy along with a copy of the source file"
+ (let* ((source-file-name (buffer-file-name buffer))
+ (temp-source-file-name (flymake-init-create-temp-buffer-copy buffer create-temp-f))
+ (master-file-name nil)
+ (temp-master-file-name nil)
+ (master-and-temp-master (flymake-create-master-file
+ source-file-name temp-source-file-name
+ get-incl-dirs-f create-temp-f
+ master-file-masks include-regexp-list)))
+
+ (if (not master-and-temp-master)
+ (progn
+ (flymake-log 1 "cannot find master file for %s" source-file-name)
+ (flymake-report-status buffer "!" "") ; NOMASTER
+ )
+ ;else
+ (progn
+ (setq master-file-name (nth 0 master-and-temp-master))
+ (setq temp-master-file-name (nth 1 master-and-temp-master))
+ (flymake-set-buffer-value buffer "master-file-name" master-file-name)
+ (flymake-set-buffer-value buffer "temp-master-file-name" temp-master-file-name)
+ )
+ )
+ temp-master-file-name
+ )
+)
+
+(defun flymake-master-cleanup(buffer)
+ (flymake-simple-cleanup buffer)
+ (flymake-safe-delete-file (flymake-get-buffer-value buffer "temp-master-file-name"))
+)
+
+;;;; make-specific init-cleanup routines
+
+(defun flymake-get-syntax-check-program-args(source-file-name base-dir use-relative-base-dir use-relative-source get-cmd-line-f)
+ "create a command line for the syntax check command, using get-cmd-line-f"
+ (let* ((my-base-dir base-dir)
+ (my-source source-file-name))
+
+ (when use-relative-base-dir
+ (setq my-base-dir (flymake-build-relative-path (file-name-directory source-file-name) base-dir))
+ )
+
+ (when use-relative-source
+ (setq my-source (concat (flymake-build-relative-path base-dir (file-name-directory source-file-name))
+ (file-name-nondirectory source-file-name)))
+ )
+
+ (funcall get-cmd-line-f my-source my-base-dir)
+ )
+)
+
+(defun flymake-get-make-cmdline(source base-dir)
+ (list "make"
+ (list "-s"
+ "-C"
+ base-dir
+ (concat "CHK_SOURCES=" source)
+ "SYNTAX_CHECK_MODE=1"
+ "check-syntax"))
+)
+
+(defun flymake-get-ant-cmdline(source base-dir)
+ (list "ant"
+ (list "-buildfile"
+ (concat base-dir "/" "build.xml")
+ (concat "-DCHK_SOURCES=" source)
+ "check-syntax"))
+)
+
+(defun flymake-simple-make-init-impl(buffer create-temp-f use-relative-base-dir use-relative-source build-file-name get-cmdline-f)
+ "create syntax check command line for a directly checked source file, use create-temp-f for creating temp copy"
+ (let* ((args nil)
+ (source-file-name (buffer-file-name buffer))
+ (buildfile-dir (flymake-init-find-buildfile-dir buffer source-file-name build-file-name)))
+ (if buildfile-dir
+ (let* ((temp-source-file-name (flymake-init-create-temp-buffer-copy buffer create-temp-f)))
+ (setq args (flymake-get-syntax-check-program-args temp-source-file-name buildfile-dir
+ use-relative-base-dir use-relative-source
+ get-cmdline-f))
+ )
+ )
+
+ args
+ )
+)
+
+(defun flymake-simple-make-init(buffer)
+ (flymake-simple-make-init-impl buffer 'flymake-create-temp-inplace t t "Makefile" 'flymake-get-make-cmdline)
+)
+
+(defun flymake-master-make-init(buffer get-incl-dirs-f master-file-masks include-regexp-list)
+ "create make command line for a source file checked via master file compilation"
+ (let* ((make-args nil)
+ (temp-master-file-name (flymake-init-create-temp-source-and-master-buffer-copy
+ buffer get-incl-dirs-f 'flymake-create-temp-inplace
+ master-file-masks include-regexp-list)))
+ (when temp-master-file-name
+ (let* ((buildfile-dir (flymake-init-find-buildfile-dir buffer temp-master-file-name "Makefile")))
+ (if buildfile-dir
+ (setq make-args (flymake-get-syntax-check-program-args
+ temp-master-file-name buildfile-dir nil nil 'flymake-get-make-cmdline))
+ )
+ )
+ )
+
+ make-args
+ )
+)
+
+(defun flymake-find-make-buildfile(source-dir)
+ (flymake-find-buildfile "Makefile" source-dir flymake-buildfile-dirs)
+)
+
+;;;; .h/make specific
+(defun flymake-master-make-header-init(buffer)
+ (flymake-master-make-init buffer
+ 'flymake-get-include-dirs
+ '(".+\\.cpp$" ".+\\.c$")
+ '("[ \t]*#[ \t]*include[ \t]*\"\\([\w0-9/\\_\.]*[/\\]*\\)\\(%s\\)\"" 1 2))
+)
+
+;;;; .java/make specific
+(defun flymake-simple-make-java-init(buffer)
+ (flymake-simple-make-init-impl buffer 'flymake-create-temp-with-folder-structure nil nil "Makefile" 'flymake-get-make-cmdline)
+)
+
+(defun flymake-simple-ant-java-init(buffer)
+ (flymake-simple-make-init-impl buffer 'flymake-create-temp-with-folder-structure nil nil "build.xml" 'flymake-get-ant-cmdline)
+)
+
+(defun flymake-simple-java-cleanup(buffer)
+ "cleanup after flymake-simple-make-java-init -- delete temp file and dirs"
+ (let* ((temp-source-file-name (flymake-get-buffer-value buffer "temp-source-file-name")))
+ (flymake-safe-delete-file temp-source-file-name)
+ (when temp-source-file-name
+ (flymake-delete-temp-directory (file-name-directory temp-source-file-name))
+ )
+ )
+)
+
+;;;; perl-specific init-cleanup routines
+
+(defun flymake-perl-init(buffer)
+ (let* ((temp-file (flymake-init-create-temp-buffer-copy buffer 'flymake-create-temp-inplace))
+ (local-file (concat (flymake-build-relative-path (file-name-directory (buffer-file-name (current-buffer)))
+ (file-name-directory temp-file))
+ (file-name-nondirectory temp-file))))
+ (list "perl" (list "-wc " local-file))
+ )
+)
+
+;;;; tex-specific init-cleanup routines
+
+(defun flymake-get-tex-args(file-name)
+ ;(list "latex" (list "-c-style-errors" file-name))
+ (list "texify" (list "--pdf" "--tex-option=-c-style-errors" file-name))
+)
+
+(defun flymake-simple-tex-init(buffer)
+ (flymake-get-tex-args (flymake-init-create-temp-buffer-copy buffer 'flymake-create-temp-inplace))
+)
+
+(defun flymake-master-tex-init(buffer)
+ (let* ((temp-master-file-name (flymake-init-create-temp-source-and-master-buffer-copy
+ buffer 'flymake-get-include-dirs-dot 'flymake-create-temp-inplace
+ '(".+\\.tex$")
+ '("[ \t]*\\input[ \t]*{\\(.*\\)\\(%s\\)}" 1 2))))
+ (when temp-master-file-name
+ (flymake-get-tex-args temp-master-file-name)
+ )
+ )
+)
+
+(defun flymake-get-include-dirs-dot(base-dir)
+ '(".")
+)
+
+;;;; xml-specific init-cleanup routines
+
+(defun flymake-xml-init(buffer)
+ (list "xml" (list "val" (flymake-init-create-temp-buffer-copy buffer 'flymake-create-temp-inplace)))
+)
+
+;;; arch-tag: 8f0d6090-061d-4cac-8862-7c151c4a02dd
+;;; flymake.el ends here
diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el
index f23eabe6e9c..88d41650c07 100644
--- a/lisp/progmodes/fortran.el
+++ b/lisp/progmodes/fortran.el
@@ -1700,8 +1700,7 @@ If ALL is nil, only match comments that start in column > 0."
(while repeat
(setq repeat nil)
;; Adapted from f90-find-breakpoint.
- (re-search-backward fortran-break-delimiters-re
- (line-beginning-position))
+ (re-search-backward fortran-break-delimiters-re bol)
(if (not fortran-break-before-delimiters)
(if (looking-at fortran-no-break-re)
;; Deal with cases such as "**" split over
diff --git a/lisp/progmodes/gdb-ui.el b/lisp/progmodes/gdb-ui.el
index 5163471f47a..2f267787707 100644
--- a/lisp/progmodes/gdb-ui.el
+++ b/lisp/progmodes/gdb-ui.el
@@ -1,6 +1,6 @@
;;; gdb-ui.el --- User Interface for running GDB
-;; Author: Nick Roberts <nick@nick.uklinux.net>
+;; Author: Nick Roberts <nickrob@gnu.org>
;; Maintainer: FSF
;; Keywords: unix, tools
@@ -40,8 +40,15 @@
;; Kingdon and uses GDB's annotation interface. You don't need to know about
;; annotations to use this mode as a debugger, but if you are interested
;; developing the mode itself, then see the Annotations section in the GDB
-;; info manual. Some GDB/MI commands are also used through th CLI command
-;; 'interpreter mi <mi-command>'.
+;; 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 in the
+;; GDB repository for future releases (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.
;;
;; Known Bugs:
;;
@@ -53,7 +60,7 @@
(defvar gdb-current-address "main" "Initialisation for Assembler buffer.")
(defvar gdb-previous-address nil)
(defvar gdb-previous-frame nil)
-(defvar gdb-current-frame "main")
+(defvar gdb-current-frame nil)
(defvar gdb-current-language nil)
(defvar gdb-view-source t "Non-nil means that source code can be viewed.")
(defvar gdb-selected-view 'source "Code type that user wishes to view.")
@@ -63,7 +70,8 @@
(defvar gdb-overlay-arrow-position nil)
(defvar gdb-variables '()
"A list of variables that are local to the GUD buffer.")
-
+(defvar gdb-server-prefix nil)
+
;;;###autoload
(defun gdba (command-line)
"Run gdb on program FILE in buffer *gud-FILE*.
@@ -73,23 +81,34 @@ 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
-other with the source file with the main routine of the debugee.
+other with the source file with the main routine of the inferior.
-If `gdb-many-windows' is t the layout below will appear
-regardless of the value of `gdb-show-main' unless
+If `gdb-many-windows' is t, regardless of the value of
+`gdb-show-main', the layout below will appear unless
`gdb-use-inferior-io-buffer' is nil when the source buffer
occupies the full width of the frame. Keybindings are given in
relevant buffer.
+Watch expressions appear in the speedbar/slowbar.
+
+The following interactive lisp functions help control operation :
+
+`gdb-many-windows' - Toggle the number of windows gdb uses.
+`gdb-restore-windows' - To restore the window layout.
+
+See Info node `(emacs)GDB Graphical Interface' for a more
+detailed description of this mode.
+
+
---------------------------------------------------------------------
GDB Toolbar
---------------------------------------------------------------------
-GUD buffer (I/O of GDB) | Locals buffer
+ GUD buffer (I/O of GDB) | Locals buffer
|
|
|
---------------------------------------------------------------------
-Source buffer | Input/Output (of debugee) buffer
+ Source buffer | Input/Output (of inferior) buffer
| (comint-mode)
|
|
@@ -98,28 +117,12 @@ Source buffer | Input/Output (of debugee) buffer
|
|
---------------------------------------------------------------------
-Stack buffer | Breakpoints buffer
+ Stack buffer | Breakpoints buffer
RET gdb-frames-select | SPC gdb-toggle-breakpoint
| RET gdb-goto-breakpoint
| d gdb-delete-breakpoint
---------------------------------------------------------------------
-
-All the buffers share the toolbar and source should always display in the same
-window e.g after typing g on a breakpoint in the breakpoints buffer. Breakpoint
-icons are displayed both by setting a break with gud-break and by typing break
-in the GUD buffer.
-
-This works best (depending on the size of your monitor) using most of the
-screen.
-
-Displayed expressions appear in separate frames. Arrays may be displayed
-as slices and visualised using the graph program from plotutils if installed.
-Pointers in structures may be followed in a tree-like fashion.
-
-The following interactive lisp functions help control operation :
-
-`gdb-many-windows' - Toggle the number of windows gdb uses.
-`gdb-restore-windows' - To restore the window layout."
+"
;;
(interactive (list (gud-query-cmdline 'gdba)))
;;
@@ -179,12 +182,17 @@ The following interactive lisp functions help control operation :
(setq gdb-current-address "main")
(setq gdb-previous-address nil)
(setq gdb-previous-frame nil)
- (setq gdb-current-frame "main")
+ (setq gdb-current-frame nil)
(setq gdb-view-source t)
(setq gdb-selected-view 'source)
(setq gdb-var-list nil)
(setq gdb-var-changed nil)
(setq gdb-first-prompt nil)
+ (setq gdb-prompting nil)
+ (setq gdb-current-item nil)
+ (setq gdb-pending-triggers nil)
+ (setq gdb-output-sink 'user)
+ (setq gdb-server-prefix "server ")
;;
(mapc 'make-local-variable gdb-variables)
(setq gdb-buffer-type 'gdba)
@@ -213,16 +221,26 @@ speedbar."
(require 'tooltip)
(let ((expr (tooltip-identifier-from-point (point))))
(if (and (string-equal gdb-current-language "c")
- gdb-use-colon-colon-notation)
+ gdb-use-colon-colon-notation gdb-current-frame)
(setq expr (concat gdb-current-frame "::" expr)))
(catch 'already-watched
(dolist (var gdb-var-list)
(if (string-equal expr (car var)) (throw 'already-watched nil)))
(set-text-properties 0 (length expr) nil expr)
(gdb-enqueue-input
- (list (concat "server interpreter mi \"-var-create - * " expr "\"\n")
+ (list
+ (if (eq gud-minor-mode 'gdba)
+ (concat "server interpreter mi \"-var-create - * " expr "\"\n")
+ (concat"-var-create - * " expr "\n"))
`(lambda () (gdb-var-create-handler ,expr))))))
- (select-window (get-buffer-window gud-comint-buffer)))
+ (select-window (get-buffer-window gud-comint-buffer 'visible)))
+
+(defun gdb-goto-info ()
+ "Go to Emacs info node: GDB Graphical Interface."
+ (interactive)
+ (select-frame (make-frame))
+ (require 'info)
+ (Info-goto-node "(emacs)GDB Graphical Interface"))
(defconst gdb-var-create-regexp
"name=\"\\(.*?\\)\",numchild=\"\\(.*?\\)\",type=\"\\(.*?\\)\"")
@@ -306,12 +324,15 @@ speedbar."
(setq gdb-var-list (nreverse var-list))))))
(defun gdb-var-update ()
- (if (not (member 'gdb-var-update (gdb-get-pending-triggers)))
+ (if (not (member 'gdb-var-update gdb-pending-triggers))
(progn
- (gdb-enqueue-input (list "server interpreter mi \"-var-update *\"\n"
+ (gdb-enqueue-input
+ (list
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ "server interpreter mi \"-var-update *\"\n"
+ "-var-update *\n")
'gdb-var-update-handler))
- (gdb-set-pending-triggers (cons 'gdb-var-update
- (gdb-get-pending-triggers))))))
+ (push 'gdb-var-update gdb-pending-triggers))))
(defconst gdb-var-update-regexp "name=\"\\(.*?\\)\"")
@@ -321,12 +342,15 @@ speedbar."
(while (re-search-forward gdb-var-update-regexp nil t)
(let ((varnum (match-string 1)))
(gdb-enqueue-input
- (list (concat "server interpreter mi \"-var-evaluate-expression "
- varnum "\"\n")
+ (list
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ (concat "server interpreter mi \"-var-evaluate-expression "
+ varnum "\"\n")
+ (concat "-var-evaluate-expression " varnum "\n"))
`(lambda () (gdb-var-evaluate-expression-handler
,varnum t)))))))
- (gdb-set-pending-triggers
- (delq 'gdb-var-update (gdb-get-pending-triggers))))
+ (setq gdb-pending-triggers
+ (delq 'gdb-var-update gdb-pending-triggers)))
(defun gdb-var-delete ()
"Delete watched expression from the speedbar."
@@ -339,8 +363,11 @@ speedbar."
(varnum (cadr var)))
(unless (string-match "\\." varnum)
(gdb-enqueue-input
- (list (concat "server interpreter mi \"-var-delete "
- varnum "\"\n")
+ (list
+ (if (with-current-buffer gud-comint-buffer
+ (eq gud-minor-mode 'gdba))
+ (concat "server interpreter mi \"-var-delete " varnum "\"\n")
+ (concat "-var-delete " varnum "\n"))
'ignore))
(setq gdb-var-list (delq var gdb-var-list))
(dolist (varchild gdb-var-list)
@@ -354,8 +381,11 @@ speedbar."
(varnum (cadr var)) (value))
(setq value (read-string "New value: "))
(gdb-enqueue-input
- (list (concat "server interpreter mi \"-var-assign "
- varnum " " value "\"\n")
+ (list
+ (if (with-current-buffer gud-comint-buffer
+ (eq gud-minor-mode 'gdba))
+ (concat "server interpreter mi \"-var-assign " varnum " " value "\"\n")
+ (concat "-var-assign " varnum " " value "\n"))
'ignore))))
(defcustom gdb-show-changed-values t
@@ -370,49 +400,25 @@ TEXT is the text of the button we clicked on, a + or - item.
TOKEN is data related to this node.
INDENT is the current indentation depth."
(cond ((string-match "+" text) ;expand this node
- (gdb-var-list-children token))
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ (gdb-var-list-children token)
+ (gdbmi-var-list-children token)))
((string-match "-" text) ;contract this node
(dolist (var gdb-var-list)
(if (string-match (concat token "\\.") (nth 1 var))
(setq gdb-var-list (delq var gdb-var-list))))
(setq gdb-var-changed t))))
-
-;; ======================================================================
-;;
-;; In this world, there are gdb variables (of unspecified
-;; representation) and buffers associated with those objects.
-;; The list of variables is built up by the expansions of
-;; def-gdb-variable
-
-(defmacro def-gdb-var (root-symbol &optional default doc)
- (let* ((root (symbol-name root-symbol))
- (accessor (intern (concat "gdb-get-" root)))
- (setter (intern (concat "gdb-set-" root)))
- (name (intern (concat "gdb-" root))))
- `(progn
- (defvar ,name ,default ,doc)
- (if (not (memq ',name gdb-variables))
- (push ',name gdb-variables))
- (defun ,accessor ()
- (buffer-local-value ',name gud-comint-buffer))
- (defun ,setter (val)
- (with-current-buffer gud-comint-buffer
- (setq ,name val))))))
-
-(def-gdb-var buffer-type nil
+(defvar gdb-buffer-type nil
"One of the symbols bound in `gdb-buffer-rules'.")
-(def-gdb-var burst ""
- "A string of characters from gdb that have not yet been processed.")
-
-(def-gdb-var input-queue ()
+(defvar gdb-input-queue ()
"A list of gdb command objects.")
-(def-gdb-var prompting nil
+(defvar gdb-prompting nil
"True when gdb is idle with no pending input.")
-(def-gdb-var output-sink 'user
+(defvar gdb-output-sink 'user
"The disposition of the output of the current gdb command.
Possible values are these symbols:
@@ -430,12 +436,14 @@ Possible values are these symbols:
gdb mode sends to gdb on its own behalf.
post-emacs -- ignore output until the prompt annotation is
received, then go to USER disposition.
-")
-(def-gdb-var current-item nil
+gdba (gdb-ui.el) uses all five values, gdbmi (gdb-mi.el) only two
+(user and emacs).")
+
+(defvar gdb-current-item nil
"The most recent command item sent to gdb.")
-(def-gdb-var pending-triggers '()
+(defvar gdb-pending-triggers '()
"A list of trigger functions that have run later than their output
handlers.")
@@ -479,8 +487,8 @@ The key should be one of the cars in `gdb-buffer-rules-assoc'."
(set (make-local-variable 'gdb-buffer-type) key)
(if (cdr (cdr rules))
(funcall (car (cdr (cdr rules)))))
- (set (make-local-variable 'gud-comint-buffer) gud-comint-buffer)
- (set (make-local-variable 'gud-minor-mode) 'gdba)
+ (set (make-local-variable 'gud-minor-mode)
+ (with-current-buffer gud-comint-buffer gud-minor-mode))
(set (make-local-variable 'tool-bar-map) gud-tool-bar-map)
new))))
@@ -548,7 +556,7 @@ The key should be one of the cars in `gdb-buffer-rules-assoc'."
(define-key map "\C-c\C-d" 'gdb-inferior-io-eof)
map))
-(define-derived-mode gdb-inferior-io-mode comint-mode "Debuggee I/O"
+(define-derived-mode gdb-inferior-io-mode comint-mode "Inferior I/O"
"Major mode for gdb inferior-io."
:syntax-table nil :abbrev-table nil
;; We want to use comint because it has various nifty and familiar
@@ -620,20 +628,18 @@ This filter may simply queue output for a later time."
;; is a query, or other non-top-level prompt.
(defun gdb-enqueue-input (item)
- (if (gdb-get-prompting)
+ (if gdb-prompting
(progn
(gdb-send-item item)
- (gdb-set-prompting nil))
- (gdb-set-input-queue
- (cons item (gdb-get-input-queue)))))
+ (setq gdb-prompting nil))
+ (push item gdb-input-queue)))
(defun gdb-dequeue-input ()
- (let ((queue (gdb-get-input-queue)))
+ (let ((queue gdb-input-queue))
(and queue
(let ((last (car (last queue))))
- (unless (nbutlast queue) (gdb-set-input-queue '()))
+ (unless (nbutlast queue) (setq gdb-input-queue '()))
last))))
-
;;
;; output -- things gdb prints to emacs
@@ -662,6 +668,8 @@ This filter may simply queue output for a later time."
("commands" gdb-subprompt)
("overload-choice" gdb-subprompt)
("query" gdb-subprompt)
+ ;; Need this prompt for GDB 6.1
+ ("nquery" gdb-subprompt)
("prompt-for-continue" gdb-subprompt)
("post-prompt" gdb-post-prompt)
("source" gdb-source)
@@ -688,89 +696,97 @@ This filter may simply queue output for a later time."
(string-to-int (match-string 2 args))))
(setq gdb-current-address (match-string 3 args))
(setq gdb-view-source t)
-;; cover for auto-display output which comes *before*
-;; stopped annotation
- (if (eq (gdb-get-output-sink) 'inferior) (gdb-set-output-sink 'user)))
+ ;; cover for auto-display output which comes *before*
+ ;; stopped annotation
+ (if (eq gdb-output-sink 'inferior) (setq gdb-output-sink 'user)))
(defun gdb-send-item (item)
(if gdb-enable-debug-log (push (cons 'send item) gdb-debug-log))
- (gdb-set-current-item item)
- (if (stringp item)
- (progn
- (gdb-set-output-sink 'user)
- (process-send-string (get-buffer-process gud-comint-buffer) item))
- (progn
+ (setq gdb-current-item item)
+ (with-current-buffer gud-comint-buffer
+ (if (eq gud-minor-mode 'gdba)
+ (progn
+ (if (stringp item)
+ (progn
+ (setq gdb-output-sink 'user)
+ (process-send-string (get-buffer-process gud-comint-buffer) item))
+ (progn
+ (gdb-clear-partial-output)
+ (setq gdb-output-sink 'pre-emacs)
+ (process-send-string (get-buffer-process gud-comint-buffer)
+ (car item)))))
+ ; case: eq gud-minor-mode 'gdbmi
(gdb-clear-partial-output)
- (gdb-set-output-sink 'pre-emacs)
+ (setq gdb-output-sink 'emacs)
(process-send-string (get-buffer-process gud-comint-buffer)
- (car item)))))
+ (car item)))))
(defun gdb-pre-prompt (ignored)
"An annotation handler for `pre-prompt'. This terminates the collection of
output from a previous command if that happens to be in effect."
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'user) t)
((eq sink 'emacs)
- (gdb-set-output-sink 'post-emacs))
+ (setq gdb-output-sink 'post-emacs))
(t
- (gdb-set-output-sink 'user)
+ (setq gdb-output-sink 'user)
(error "Phase error in gdb-pre-prompt (got %s)" sink)))))
(defun gdb-prompt (ignored)
"An annotation handler for `prompt'.
This sends the next command (if any) to gdb."
(when gdb-first-prompt (gdb-ann3))
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'user) t)
((eq sink 'post-emacs)
- (gdb-set-output-sink 'user)
+ (setq gdb-output-sink 'user)
(let ((handler
- (car (cdr (gdb-get-current-item)))))
+ (car (cdr gdb-current-item))))
(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
(funcall handler))))
(t
- (gdb-set-output-sink 'user)
+ (setq gdb-output-sink 'user)
(error "Phase error in gdb-prompt (got %s)" sink))))
(let ((input (gdb-dequeue-input)))
(if input
(gdb-send-item input)
(progn
- (gdb-set-prompting t)
+ (setq gdb-prompting t)
(gud-display-frame)))))
(defun gdb-subprompt (ignored)
"An annotation handler for non-top-level prompts."
- (gdb-set-prompting t))
+ (setq gdb-prompting t))
(defun gdb-starting (ignored)
"An annotation handler for `starting'. This says that I/O for the
subprocess is now the program being debugged, not GDB."
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'user)
(progn
(setq gud-running t)
(if gdb-use-inferior-io-buffer
- (gdb-set-output-sink 'inferior))))
+ (setq gdb-output-sink 'inferior))))
(t (error "Unexpected `starting' annotation")))))
(defun gdb-stopping (ignored)
"An annotation handler for `exited' and other annotations which say that I/O
for the subprocess is now GDB, not the program being debugged."
(if gdb-use-inferior-io-buffer
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'inferior)
- (gdb-set-output-sink 'user))
+ (setq gdb-output-sink 'user))
(t (error "Unexpected stopping annotation"))))))
(defun gdb-frame-begin (ignored)
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'inferior)
- (gdb-set-output-sink 'user))
+ (setq gdb-output-sink 'user))
((eq sink 'user) t)
((eq sink 'emacs) t)
(t (error "Unexpected frame-begin annotation (%S)" sink)))))
@@ -779,17 +795,17 @@ for the subprocess is now GDB, not the program being debugged."
"An annotation handler for `stopped'. It is just like gdb-stopping, except
that if we already set the output sink to 'user in gdb-stopping, that is fine."
(setq gud-running nil)
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'inferior)
- (gdb-set-output-sink 'user))
+ (setq gdb-output-sink 'user))
((eq sink 'user) t)
(t (error "Unexpected stopped annotation")))))
(defun gdb-post-prompt (ignored)
"An annotation handler for `post-prompt'. This begins the collection of
output from the current command if that happens to be appropriate."
- (if (not (gdb-get-pending-triggers))
+ (if (not gdb-pending-triggers)
(progn
(gdb-get-current-frame)
(gdb-invalidate-frames)
@@ -806,13 +822,13 @@ output from the current command if that happens to be appropriate."
(dolist (var gdb-var-list)
(setcar (nthcdr 5 var) nil))))
(gdb-var-update))))
- (let ((sink (gdb-get-output-sink)))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'user) t)
((eq sink 'pre-emacs)
- (gdb-set-output-sink 'emacs))
+ (setq gdb-output-sink 'emacs))
(t
- (gdb-set-output-sink 'user)
+ (setq gdb-output-sink 'user)
(error "Phase error in gdb-post-prompt (got %s)" sink)))))
(defun gud-gdba-marker-filter (string)
@@ -874,7 +890,7 @@ output from the current command if that happens to be appropriate."
output))
(defun gdb-concat-output (so-far new)
- (let ((sink (gdb-get-output-sink )))
+ (let ((sink gdb-output-sink))
(cond
((eq sink 'user) (concat so-far new))
((or (eq sink 'pre-emacs) (eq sink 'post-emacs)) so-far)
@@ -936,19 +952,17 @@ output from the current command if that happens to be appropriate."
`(defun ,name (&optional ignored)
(if (and (,demand-predicate)
(not (member ',name
- (gdb-get-pending-triggers))))
+ gdb-pending-triggers)))
(progn
(gdb-enqueue-input
(list ,gdb-command ',output-handler))
- (gdb-set-pending-triggers
- (cons ',name
- (gdb-get-pending-triggers)))))))
+ (push ',name gdb-pending-triggers)))))
(defmacro def-gdb-auto-update-handler (name trigger buf-key custom-defun)
`(defun ,name ()
- (gdb-set-pending-triggers
+ (setq gdb-pending-triggers
(delq ',trigger
- (gdb-get-pending-triggers)))
+ gdb-pending-triggers))
(let ((buf (gdb-get-buffer ',buf-key)))
(and buf
(with-current-buffer buf
@@ -1080,7 +1094,7 @@ static char *magick[] = {
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(if (and (eq gud-minor-mode 'gdba)
- (not (string-match "^\*" (buffer-name))))
+ (not (string-match "\\`\\*.+\\*\\'" (buffer-name))))
(gdb-remove-breakpoint-icons (point-min) (point-max)))))
(with-current-buffer (gdb-get-buffer 'gdb-breakpoints-buffer)
(save-excursion
@@ -1112,10 +1126,11 @@ static char *magick[] = {
(save-excursion
(goto-line (string-to-number line))
(gdb-put-breakpoint-icon (eq flag ?y)))))))))
- (end-of-line))))))
+ (end-of-line)))))
+ (if (gdb-get-buffer 'gdb-assembler-buffer) (gdb-assembler-custom)))
(defun gdb-mouse-toggle-breakpoint (event)
- "Toggle breakpoint with mouse click in left margin."
+ "Toggle breakpoint in left fringe/margin with mouse click"
(interactive "e")
(mouse-minibuffer-check event)
(let ((posn (event-end event)))
@@ -1135,14 +1150,24 @@ static char *magick[] = {
(concat "*breakpoints of " (gdb-get-target-string) "*")))
(defun gdb-display-breakpoints-buffer ()
+ "Display status of user-settable breakpoints."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-breakpoints-buffer)))
+(defconst gdb-frame-parameters
+ '((height . 12) (width . 60)
+ (unsplittable . t)
+ (tool-bar-lines . nil)
+ (menu-bar-lines . nil)
+ (minibuffer . nil)))
+
(defun gdb-frame-breakpoints-buffer ()
+ "Display status of user-settable breakpoints in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-breakpoints-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-breakpoints-buffer))
+ (set-window-dedicated-p (selected-window) t))
(defvar gdb-breakpoints-mode-map
(let ((map (make-sparse-keymap))
@@ -1167,7 +1192,9 @@ static char *magick[] = {
(setq mode-name "Breakpoints")
(use-local-map gdb-breakpoints-mode-map)
(setq buffer-read-only t)
- (gdb-invalidate-breakpoints))
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ (gdb-invalidate-breakpoints)
+ (gdbmi-invalidate-breakpoints)))
(defun gdb-toggle-breakpoint ()
"Enable/disable the breakpoint at current line."
@@ -1180,8 +1207,8 @@ static char *magick[] = {
(list
(concat
(if (eq ?y (char-after (match-beginning 2)))
- "server disable "
- "server enable ")
+ gdb-server-prefix "disable "
+ gdb-server-prefix "enable ")
(match-string 1) "\n")
'ignore)))))
@@ -1192,28 +1219,31 @@ static char *magick[] = {
(if (not (looking-at "\\([0-9]+\\).*point\\s-*\\S-*\\s-*\\(.\\)"))
(error "Not recognized as break/watchpoint line")
(gdb-enqueue-input
- (list (concat "server delete " (match-string 1) "\n") 'ignore))))
+ (list (concat gdb-server-prefix "delete " (match-string 1) "\n") 'ignore))))
(defun gdb-goto-breakpoint ()
- "Display the file in the source buffer at the breakpoint specified on the
-current line."
+ "Display the breakpoint location specified at current line."
(interactive)
(save-excursion
(beginning-of-line 1)
- (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
- (looking-at "\\(\\S-*\\):\\([0-9]+\\)"))
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdbmi))
+ (looking-at "[0-9]*\\s-*\\S-*\\s-*\\S-*\\s-*.\\s-*\\S-*\\s-*\\(\\S-*\\):\\([0-9]+\\)")
+ (re-search-forward "in\\s-+\\S-+\\s-+at\\s-+" nil t)
+ (looking-at "\\(\\S-*\\):\\([0-9]+\\)")))
(if (match-string 2)
(let ((line (match-string 2))
(file (match-string 1)))
(save-selected-window
- (gdb-display-buffer (find-file-noselect
- (if (file-exists-p file)
- file
- (expand-file-name file gdb-cdir))))
- (goto-line (string-to-number line))))))
+ (let* ((buf (find-file-noselect (if (file-exists-p file)
+ file
+ (expand-file-name file gdb-cdir))))
+ (window (gdb-display-buffer buf)))
+ (with-current-buffer buf
+ (goto-line (string-to-number line))
+ (set-window-point window (point))))))))
(defun gdb-mouse-goto-breakpoint (event)
- "Display the file in the source buffer at the selected breakpoint."
+ "Display the breakpoint location that you click on."
(interactive "e")
(mouse-set-point event)
(gdb-goto-breakpoint))
@@ -1256,14 +1286,17 @@ current line."
(concat "*stack frames of " (gdb-get-target-string) "*")))
(defun gdb-display-stack-buffer ()
+ "Display backtrace of current stack."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-stack-buffer)))
(defun gdb-frame-stack-buffer ()
+ "Display backtrace of current stack in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-stack-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-stack-buffer))
+ (set-window-dedicated-p (selected-window) t))
(defvar gdb-frames-mode-map
(let ((map (make-sparse-keymap)))
@@ -1281,25 +1314,25 @@ current line."
(setq buffer-read-only t)
(use-local-map gdb-frames-mode-map)
(font-lock-mode -1)
- (gdb-invalidate-frames))
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ (gdb-invalidate-frames)
+ (gdbmi-invalidate-frames)))
(defun gdb-get-frame-number ()
(save-excursion
- (let* ((pos (re-search-backward "^#\\([0-9]*\\)" nil t))
+ (let* ((pos (re-search-backward "^#*\\([0-9]*\\)" nil t))
(n (or (and pos (match-string-no-properties 1)) "0")))
n)))
(defun gdb-frames-select ()
- "Make the frame on the current line become the current frame and display the
-source in the source buffer."
+ "Select the frame and display the relevant source."
(interactive)
(gdb-enqueue-input
- (list (concat "server frame " (gdb-get-frame-number) "\n") 'ignore))
+ (list (concat gdb-server-prefix "frame " (gdb-get-frame-number) "\n") 'ignore))
(gud-display-frame))
(defun gdb-frames-mouse-select (event)
- "Make the selected frame become the current frame and display the source in
-the source buffer."
+ "Select the frame you click on and display the relevant source."
(interactive "e")
(mouse-set-point event)
(gdb-frames-select))
@@ -1313,7 +1346,7 @@ the source buffer."
(def-gdb-auto-updated-buffer gdb-threads-buffer
gdb-invalidate-threads
- "server info threads\n"
+ (concat gdb-server-prefix "info threads\n")
gdb-info-threads-handler
gdb-info-threads-custom)
@@ -1332,14 +1365,17 @@ the source buffer."
(concat "*threads of " (gdb-get-target-string) "*")))
(defun gdb-display-threads-buffer ()
+ "Display IDs of currently known threads."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-threads-buffer)))
(defun gdb-frame-threads-buffer ()
+ "Display IDs of currently known threads in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-threads-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-threads-buffer))
+ (set-window-dedicated-p (selected-window) t))
(defvar gdb-threads-mode-map
(let ((map (make-sparse-keymap)))
@@ -1351,7 +1387,7 @@ the source buffer."
(defun gdb-threads-mode ()
"Major mode for gdb frames.
-\\{gdb-frames-mode-map}"
+\\{gdb-threads-mode-map}"
(setq major-mode 'gdb-threads-mode)
(setq mode-name "Threads")
(setq buffer-read-only t)
@@ -1364,16 +1400,14 @@ the source buffer."
(match-string-no-properties 1)))
(defun gdb-threads-select ()
- "Make the thread on the current line become the current thread and display the
-source in the source buffer."
+ "Select the thread and display the relevant source."
(interactive)
(gdb-enqueue-input
(list (concat "thread " (gdb-get-thread-number) "\n") 'ignore))
(gud-display-frame))
(defun gdb-threads-mouse-select (event)
- "Make the selected frame become the current frame and display the source in
-the source buffer."
+ "Select the thread you click on and display the relevant source."
(interactive "e")
(mouse-set-point event)
(gdb-threads-select))
@@ -1387,7 +1421,7 @@ the source buffer."
(def-gdb-auto-updated-buffer gdb-registers-buffer
gdb-invalidate-registers
- "server info registers\n"
+ (concat gdb-server-prefix "info registers\n")
gdb-info-registers-handler
gdb-info-registers-custom)
@@ -1413,14 +1447,17 @@ the source buffer."
(concat "*registers of " (gdb-get-target-string) "*")))
(defun gdb-display-registers-buffer ()
+ "Display integer register contents."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-registers-buffer)))
(defun gdb-frame-registers-buffer ()
+ "Display integer register contents in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-registers-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-registers-buffer))
+ (set-window-dedicated-p (selected-window) t))
;;
;; Locals buffer.
@@ -1438,8 +1475,8 @@ the source buffer."
;; Abbreviate for arrays and structures.
;; These can be expanded using gud-display.
(defun gdb-info-locals-handler nil
- (gdb-set-pending-triggers (delq 'gdb-invalidate-locals
- (gdb-get-pending-triggers)))
+ (setq gdb-pending-triggers (delq 'gdb-invalidate-locals
+ gdb-pending-triggers))
(let ((buf (gdb-get-buffer 'gdb-partial-output-buffer)))
(with-current-buffer buf
(goto-char (point-min))
@@ -1474,24 +1511,29 @@ the source buffer."
\\{gdb-locals-mode-map}"
(setq major-mode 'gdb-locals-mode)
- (setq mode-name "Locals")
+ (setq mode-name (concat "Locals:" gdb-current-frame))
(setq buffer-read-only t)
(use-local-map gdb-locals-mode-map)
- (gdb-invalidate-locals))
+ (if (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))
+ (gdb-invalidate-locals)
+ (gdbmi-invalidate-locals)))
(defun gdb-locals-buffer-name ()
(with-current-buffer gud-comint-buffer
(concat "*locals of " (gdb-get-target-string) "*")))
(defun gdb-display-locals-buffer ()
+ "Display local variables of current stack and their values."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-locals-buffer)))
(defun gdb-frame-locals-buffer ()
+ "Display local variables of current stack and their values in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-locals-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-locals-buffer))
+ (set-window-dedicated-p (selected-window) t))
;;;; Window management
@@ -1510,9 +1552,9 @@ the source buffer."
#'(lambda (win)
(if (eq gud-comint-buffer (window-buffer win))
(set-window-dedicated-p win t))))
- (setq answer (get-buffer-window buf))
+ (setq answer (get-buffer-window buf 'visible))
(if (not answer)
- (let ((window (get-lru-window)))
+ (let ((window (get-lru-window 'visible)))
(if window
(progn
(set-window-buffer window buf)
@@ -1523,7 +1565,7 @@ the source buffer."
(if (eq gud-comint-buffer (window-buffer win))
(set-window-dedicated-p win nil)))))
(if must-split
- (let* ((largest (get-largest-window))
+ (let* ((largest (get-largest-window 'visible))
(cur-size (window-height largest))
(new-size (and size (< size cur-size) (- cur-size size))))
(setq answer (split-window largest new-size))
@@ -1532,11 +1574,9 @@ the source buffer."
(defun gdb-display-source-buffer (buffer)
(if (eq gdb-selected-view 'source)
- (progn
(gdb-display-buffer buffer)
- (get-buffer-window buffer))
- (gdb-display-buffer (gdb-get-buffer 'gdb-assembler-buffer))
- nil))
+ (gdb-display-buffer (gdb-get-buffer 'gdb-assembler-buffer)))
+ (get-buffer-window buffer 'visible))
;;; Shared keymap initialization:
@@ -1545,25 +1585,23 @@ the source buffer."
(define-key gud-menu-map [frames]
`(menu-item "GDB-Frames" ,menu :visible (eq gud-minor-mode 'gdba)))
(define-key menu [gdb] '("Gdb" . gdb-frame-gdb-buffer))
- (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
+ (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
+ (define-key menu [assembler] '("Machine" . gdb-frame-assembler-buffer))
(define-key menu [registers] '("Registers" . gdb-frame-registers-buffer))
+ (define-key menu [locals] '("Locals" . gdb-frame-locals-buffer))
(define-key menu [frames] '("Stack" . gdb-frame-stack-buffer))
- (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer))
- (define-key menu [threads] '("Threads" . gdb-frame-threads-buffer))
-; (define-key menu [assembler] '("Machine" . gdb-frame-assembler-buffer))
-)
+ (define-key menu [breakpoints] '("Breakpoints" . gdb-frame-breakpoints-buffer)))
(let ((menu (make-sparse-keymap "GDB-Windows")))
(define-key gud-menu-map [displays]
`(menu-item "GDB-Windows" ,menu :visible (eq gud-minor-mode 'gdba)))
(define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer))
- (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
+ (define-key menu [assembler] '("Machine" . gdb-display-assembler-buffer))
+ (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
(define-key menu [registers] '("Registers" . gdb-display-registers-buffer))
+ (define-key menu [locals] '("Locals" . gdb-display-locals-buffer))
(define-key menu [frames] '("Stack" . gdb-display-stack-buffer))
- (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer))
- (define-key menu [threads] '("Threads" . gdb-display-threads-buffer))
-; (define-key menu [assembler] '("Machine" . gdb-display-assembler-buffer))
-)
+ (define-key menu [breakpoints] '("Breakpoints" . gdb-display-breakpoints-buffer)))
(let ((menu (make-sparse-keymap "View")))
(define-key gud-menu-map [view]
@@ -1589,11 +1627,14 @@ the source buffer."
"Display locals, stack and breakpoint information")))
(defun gdb-frame-gdb-buffer ()
+ "Display GUD buffer in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdba)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdba))
+ (set-window-dedicated-p (selected-window) t))
(defun gdb-display-gdb-buffer ()
+ "Display GUD buffer."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdba)))
@@ -1601,6 +1642,7 @@ the source buffer."
(defvar gdb-main-file nil "Source file from which program execution begins.")
(defun gdb-view-source-function ()
+ "Select source view."
(interactive)
(if gdb-view-source
(gdb-display-buffer
@@ -1610,8 +1652,10 @@ the source buffer."
(setq gdb-selected-view 'source))
(defun gdb-view-assembler()
+ "Select disassembly view."
(interactive)
(gdb-display-buffer (gdb-get-create-buffer 'gdb-assembler-buffer))
+ (gdb-invalidate-assembler)
(setq gdb-selected-view 'assembler))
;(defun gdb-view-both()
@@ -1656,10 +1700,10 @@ the source buffer."
(other-window 1))
(defcustom gdb-many-windows nil
- "Nil (the default value) means just pops up the GUD buffer
+ "Nil (the default value) means just pop 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 other with the
-source file with the main routine of the debugee. Non-nil means
+source file with the main routine of the inferior. Non-nil means
display the layout shown for `gdba'."
:type 'boolean
:group 'gud)
@@ -1701,15 +1745,15 @@ This arrangement depends on the value of `gdb-many-windows'."
"Exit a debugging session cleanly by killing the gdb buffers and resetting
the source buffers."
(dolist (buffer (buffer-list))
- (if (not (eq buffer gud-comint-buffer))
- (with-current-buffer buffer
- (if (memq gud-minor-mode '(gdba pdb))
- (if (string-match "^\*.+*$" (buffer-name))
- (kill-buffer nil)
- (gdb-remove-breakpoint-icons (point-min) (point-max) t)
- (setq gud-minor-mode nil)
- (kill-local-variable 'tool-bar-map)
- (setq gud-running nil))))))
+ (unless (eq buffer gud-comint-buffer)
+ (with-current-buffer buffer
+ (if (memq gud-minor-mode '(gdbmi gdba))
+ (if (string-match "\\`\\*.+\\*\\'" (buffer-name))
+ (kill-buffer nil)
+ (gdb-remove-breakpoint-icons (point-min) (point-max) t)
+ (setq gud-minor-mode nil)
+ (kill-local-variable 'tool-bar-map)
+ (setq gud-running nil))))))
(when (markerp gdb-overlay-arrow-position)
(move-marker gdb-overlay-arrow-position nil)
(setq gdb-overlay-arrow-position nil))
@@ -1791,11 +1835,10 @@ BUFFER nil or omitted means use the current buffer."
(when (< left-margin-width 2)
(save-current-buffer
(setq left-margin-width 2)
- (if (get-buffer-window (current-buffer))
- (set-window-margins (get-buffer-window
- (current-buffer))
- left-margin-width
- right-margin-width))))
+ (if (get-buffer-window (current-buffer) 'visible)
+ (set-window-margins
+ (get-buffer-window (current-buffer) 'visible)
+ left-margin-width right-margin-width))))
(put-image
(if enabled
(or breakpoint-enabled-icon
@@ -1819,11 +1862,10 @@ BUFFER nil or omitted means use the current buffer."
(when (< left-margin-width 2)
(save-current-buffer
(setq left-margin-width 2)
- (if (get-buffer-window (current-buffer))
- (set-window-margins (get-buffer-window
- (current-buffer))
- left-margin-width
- right-margin-width))))
+ (if (get-buffer-window (current-buffer) 'visible)
+ (set-window-margins
+ (get-buffer-window (current-buffer) 'visible)
+ left-margin-width right-margin-width))))
(gdb-put-string (if enabled "B" "b") (1+ start)))))
(defun gdb-remove-breakpoint-icons (start end &optional remove-margin)
@@ -1832,11 +1874,10 @@ BUFFER nil or omitted means use the current buffer."
(remove-images start end))
(when remove-margin
(setq left-margin-width 0)
- (if (get-buffer-window (current-buffer))
- (set-window-margins (get-buffer-window
- (current-buffer))
- left-margin-width
- right-margin-width))))
+ (if (get-buffer-window (current-buffer) 'visible)
+ (set-window-margins
+ (get-buffer-window (current-buffer) 'visible)
+ left-margin-width right-margin-width))))
;;
@@ -1848,7 +1889,7 @@ BUFFER nil or omitted means use the current buffer."
(def-gdb-auto-updated-buffer gdb-assembler-buffer
gdb-invalidate-assembler
- (concat "server disassemble " gdb-current-address "\n")
+ (concat gdb-server-prefix "disassemble " gdb-current-address "\n")
gdb-assembler-handler
gdb-assembler-custom)
@@ -1887,7 +1928,7 @@ BUFFER nil or omitted means use the current buffer."
(if (re-search-forward address nil t)
(gdb-put-breakpoint-icon (eq flag ?y))))))))
(if (not (equal gdb-current-address "main"))
- (set-window-point (get-buffer-window buffer) pos))))
+ (set-window-point (get-buffer-window buffer 'visible) pos))))
(defvar gdb-assembler-mode-map
(let ((map (make-sparse-keymap)))
@@ -1913,14 +1954,17 @@ BUFFER nil or omitted means use the current buffer."
(concat "*Machine Code " (gdb-get-target-string) "*")))
(defun gdb-display-assembler-buffer ()
+ "Display disassembly view."
(interactive)
(gdb-display-buffer
(gdb-get-create-buffer 'gdb-assembler-buffer)))
(defun gdb-frame-assembler-buffer ()
+ "Display disassembly view in a new frame."
(interactive)
- (switch-to-buffer-other-frame
- (gdb-get-create-buffer 'gdb-assembler-buffer)))
+ (select-frame (make-frame gdb-frame-parameters))
+ (switch-to-buffer (gdb-get-create-buffer 'gdb-assembler-buffer))
+ (set-window-dedicated-p (selected-window) t))
;; modified because if gdb-current-address has changed value a new command
;; must be enqueued to update the buffer with the new output
@@ -1929,44 +1973,44 @@ BUFFER nil or omitted means use the current buffer."
(progn
(unless (string-equal gdb-current-frame gdb-previous-frame)
(if (or (not (member 'gdb-invalidate-assembler
- (gdb-get-pending-triggers)))
+ gdb-pending-triggers))
(not (string-equal gdb-current-address
gdb-previous-address)))
(progn
;; take previous disassemble command off the queue
(with-current-buffer gud-comint-buffer
- (let ((queue (gdb-get-input-queue)) (item))
+ (let ((queue gdb-input-queue) (item))
(dolist (item queue)
(if (equal (cdr item) '(gdb-assembler-handler))
- (gdb-set-input-queue
- (delete item (gdb-get-input-queue)))))))
+ (setq gdb-input-queue
+ (delete item gdb-input-queue))))))
(gdb-enqueue-input
- (list (concat "server disassemble " gdb-current-address "\n")
+ (list (concat gdb-server-prefix "disassemble " gdb-current-address "\n")
'gdb-assembler-handler))
- (gdb-set-pending-triggers
- (cons 'gdb-invalidate-assembler
- (gdb-get-pending-triggers)))
+ (push 'gdb-invalidate-assembler gdb-pending-triggers)
(setq gdb-previous-address gdb-current-address)
(setq gdb-previous-frame gdb-current-frame)))))))
(defun gdb-get-current-frame ()
- (if (not (member 'gdb-get-current-frame (gdb-get-pending-triggers)))
+ (if (not (member 'gdb-get-current-frame gdb-pending-triggers))
(progn
(gdb-enqueue-input
- (list (concat "server info frame\n") 'gdb-frame-handler))
- (gdb-set-pending-triggers
- (cons 'gdb-get-current-frame
- (gdb-get-pending-triggers))))))
+ (list (concat gdb-server-prefix "info frame\n") 'gdb-frame-handler))
+ (push 'gdb-get-current-frame
+ gdb-pending-triggers))))
(defun gdb-frame-handler ()
- (gdb-set-pending-triggers
- (delq 'gdb-get-current-frame (gdb-get-pending-triggers)))
+ (setq gdb-pending-triggers
+ (delq 'gdb-get-current-frame gdb-pending-triggers))
(with-current-buffer (gdb-get-create-buffer 'gdb-partial-output-buffer)
(goto-char (point-min))
(forward-line)
- (if (looking-at ".*=\\s-+0x\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*\\)")
+ (if (looking-at ".*=\\s-+0x\\(\\S-*\\)\\s-+in\\s-+\\(\\S-*?\\);? ")
(progn
(setq gdb-current-frame (match-string 2))
+ (if (gdb-get-buffer 'gdb-locals-buffer)
+ (with-current-buffer (gdb-get-buffer 'gdb-locals-buffer)
+ (setq mode-name (concat "Locals:" gdb-current-frame))))
(let ((address (match-string 1)))
;; remove leading 0s from output of info frame command.
(if (string-match "^0+\\(.*\\)" address)
@@ -1986,5 +2030,5 @@ BUFFER nil or omitted means use the current buffer."
(provide 'gdb-ui)
-;;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352
+;; arch-tag: e9fb00c5-74ef-469f-a088-37384caae352
;;; gdb-ui.el ends here
diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el
index 94937ba1e87..aa9a50a2580 100644
--- a/lisp/progmodes/grep.el
+++ b/lisp/progmodes/grep.el
@@ -216,7 +216,7 @@ Notice that using \\[next-error] or \\[compile-goto-error] modifies
`complation-last-buffer' rather than `grep-last-buffer'.")
(defvar grep-regexp-alist
- '(("^\\(.+?\\)[:( \t]+\\([0-9]+\\)[:) \t]" 1 2)
+ '(("^\\(.+?\\)[:( \t]+\\([0-9]+\\)\\([:) \t]\\)\\(?:\\([0-9]+\\)\\(?:-\\([0-9]+\\)\\)?\\3\\)?" 1 2 (4 . 5))
("^Binary file \\(.+\\) matches$" 1 nil nil 1))
"Regexp used to match grep hits. See `compilation-error-regexp-alist'.")
@@ -555,7 +555,7 @@ those sub directories of DIR."
nil) ;; we change default-directory to dir
(and grep-tree-ignore-CVS-directories "-path '*/CVS' -prune -o ")
grep-tree-ignore-case))
- (default-directory dir)
+ (default-directory (file-name-as-directory (expand-file-name dir)))
(null-device nil)) ; see grep
(grep command-args regexp)))
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index a34b0bb2d48..4ea4fcb6ea2 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -4,7 +4,7 @@
;; Maintainer: FSF
;; Keywords: unix, tools
-;; Copyright (C) 1992,93,94,95,96,1998,2000,02,2003 Free Software Foundation, Inc.
+;; Copyright (C) 1992,93,94,95,96,1998,2000,02,03,04 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -92,44 +92,44 @@ If SOFT is non-nil, returns nil if the symbol doesn't already exist."
Used to grey out relevant toolbar icons.")
(easy-mmode-defmap gud-menu-map
- '(([refresh] "Refresh" . gud-refresh)
+ '(([help] menu-item "Help" gdb-goto-info
+ :enable (memq gud-minor-mode '(gdbmi gdba)))
+ ([refresh] "Refresh" . gud-refresh)
([run] menu-item "Run" gud-run
- :enable (and (not gud-running)
- (memq gud-minor-mode '(gdba gdb dbx jdb))))
+ :enable (and (not gud-running)
+ (memq gud-minor-mode '(gdbmi gdba gdb dbx jdb))))
([until] menu-item "Continue to selection" gud-until
- :enable (and (not gud-running)
- (memq gud-minor-mode '(gdba gdb perldb))))
+ :enable (and (not gud-running)
+ (memq gud-minor-mode '(gdbmi gdba gdb perldb))))
([remove] menu-item "Remove Breakpoint" gud-remove
- :enable (not gud-running))
+ :enable (not gud-running))
([tbreak] menu-item "Temporary Breakpoint" gud-tbreak
- :enable (memq gud-minor-mode '(gdba gdb sdb xdb bashdb)))
+ :enable (memq gud-minor-mode '(gdbmi gdba gdb sdb xdb bashdb)))
([break] menu-item "Set Breakpoint" gud-break
- :enable (not gud-running))
+ :enable (not gud-running))
([up] menu-item "Up Stack" gud-up
- :enable (and (not gud-running)
- (memq gud-minor-mode
- '(gdba gdb dbx xdb jdb pdb bashdb))))
+ :enable (and (not gud-running)
+ (memq gud-minor-mode
+ '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))))
([down] menu-item "Down Stack" gud-down
- :enable (and (not gud-running)
- (memq gud-minor-mode
- '(gdba gdb dbx xdb jdb pdb bashdb))))
+ :enable (and (not gud-running)
+ (memq gud-minor-mode
+ '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))))
([print] menu-item "Print Expression" gud-print
:enable (not gud-running))
([watch] menu-item "Watch Expression" gud-watch
:enable (and (not gud-running)
- (eq gud-minor-mode 'gdba)))
+ (memq gud-minor-mode '(gdbmi gdba))))
([finish] menu-item "Finish Function" gud-finish
:enable (and (not gud-running)
(memq gud-minor-mode
- '(gdba gdb xdb jdb pdb bashdb))))
+ '(gdbmi gdba gdb xdb jdb pdb bashdb))))
([stepi] menu-item "Step Instruction" gud-stepi
:enable (and (not gud-running)
- (memq gud-minor-mode
- '(gdba gdb dbx))))
+ (memq gud-minor-mode '(gdbmi gdba gdb dbx))))
([nexti] menu-item "Next Instruction" gud-nexti
:enable (and (not gud-running)
- (memq gud-minor-mode
- '(gdba gdb dbx))))
+ (memq gud-minor-mode '(gdbmi gdba gdb dbx))))
([step] menu-item "Step Line" gud-step
:enable (not gud-running))
([next] menu-item "Next Line" gud-next
@@ -171,7 +171,8 @@ Used to grey out relevant toolbar icons.")
(gud-stepi . "gud-si")
(gud-nexti . "gud-ni")
(gud-up . "gud-up")
- (gud-down . "gud-down"))
+ (gud-down . "gud-down")
+ (gdb-goto-info . "help"))
map)
(tool-bar-local-item-from-menu
(car x) (cdr x) map gud-minor-mode-map)))))
@@ -312,11 +313,14 @@ t means that there is no stack, and we are in display-file mode.")
(defvar gud-speedbar-menu-items
;; Note to self. Add expand, and turn off items when not available.
'(["Jump to stack frame" speedbar-edit-line
- (with-current-buffer gud-comint-buffer (not (eq gud-minor-mode 'gdba)))]
+ (with-current-buffer gud-comint-buffer
+ (not (memq gud-minor-mode '(gdbmi gdba))))]
["Edit value" speedbar-edit-line
- (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))]
+ (with-current-buffer gud-comint-buffer
+ (not (memq gud-minor-mode '(gdbmi gdba))))]
["Delete expression" gdb-var-delete
- (with-current-buffer gud-comint-buffer (eq gud-minor-mode 'gdba))])
+ (with-current-buffer gud-comint-buffer
+ (not (memq gud-minor-mode '(gdbmi gdba))))])
"Additional menu items to add to the speedbar frame.")
;; Make sure our special speedbar mode is loaded
@@ -330,7 +334,7 @@ If the GUD BUFFER is not running a supported debugger, then turn
off the specialized speedbar mode."
(let ((minor-mode (with-current-buffer buffer gud-minor-mode)))
(cond
- ((eq minor-mode 'gdba)
+ ((memq minor-mode '(gdbmi gdba))
(when (or gdb-var-changed
(not (save-excursion
(goto-char (point-min))
@@ -397,7 +401,7 @@ off the specialized speedbar mode."
(speedbar-insert-button (car frame)
'speedbar-file-face
'speedbar-highlight-face
- (cond ((memq minor-mode '(gdba gdb))
+ (cond ((memq minor-mode '(gdbmi gdba gdb))
'gud-gdb-goto-stackframe)
(t (error "Should never be here")))
frame t)))
@@ -1401,7 +1405,7 @@ and source-file directory for your debugger."
output))
-(defcustom gud-pdb-command-name "pdb"
+(defcustom gud-pdb-command-name "pydb"
"File name for executing the Python debugger.
This should be an executable on your path, or an absolute file name."
:type 'string
@@ -2339,7 +2343,8 @@ comint mode, which see."
;; Don't put repeated commands in command history many times.
(set (make-local-variable 'comint-input-ignoredups) t)
(make-local-variable 'paragraph-start)
- (set (make-local-variable 'gud-delete-prompt-marker) (make-marker)))
+ (set (make-local-variable 'gud-delete-prompt-marker) (make-marker))
+ (add-hook 'kill-buffer-hook 'gud-kill-buffer-hook nil t))
;; Cause our buffers to be displayed, by default,
;; in the selected window.
@@ -2384,8 +2389,11 @@ comint mode, which see."
(if (file-name-directory file-subst)
(expand-file-name file-subst)
file-subst)))
- (filepart (and file-word (concat "-" (file-name-nondirectory file)))))
+ (filepart (and file-word (concat "-" (file-name-nondirectory file))))
+ (existing-buffer (get-buffer (concat "*gud" filepart "*"))))
(pop-to-buffer (concat "*gud" filepart "*"))
+ (when (and existing-buffer (get-buffer-process existing-buffer))
+ (error "This program is already running under gdb"))
;; Set the dir, in case the buffer already existed with a different dir.
(setq default-directory dir)
;; Set default-directory to the file's directory.
@@ -2507,14 +2515,14 @@ It is saved for when this flag is not set.")
;; Stop displaying an arrow in a source file.
(setq overlay-arrow-position nil)
(set-process-buffer proc nil)
- (if (eq gud-minor-mode-type 'gdba)
+ (if (memq gud-minor-mode-type '(gdbmi gdba))
(gdb-reset)
(gud-reset)))
((memq (process-status proc) '(signal exit))
;; Stop displaying an arrow in a source file.
(setq overlay-arrow-position nil)
(with-current-buffer gud-comint-buffer
- (if (eq gud-minor-mode 'gdba)
+ (if (memq gud-minor-mode-type '(gdbmi gdba))
(gdb-reset)
(gud-reset)))
(let* ((obuf (current-buffer)))
@@ -2543,19 +2551,18 @@ It is saved for when this flag is not set.")
(set-buffer obuf))))))
(defun gud-kill-buffer-hook ()
- (if gud-minor-mode
- (setq gud-minor-mode-type gud-minor-mode)))
-
-(add-hook 'kill-buffer-hook 'gud-kill-buffer-hook)
+ (setq gud-minor-mode-type gud-minor-mode)
+ (condition-case nil
+ (kill-process (get-buffer-process gud-comint-buffer))
+ (error nil)))
(defun gud-reset ()
(dolist (buffer (buffer-list))
- (if (not (eq buffer gud-comint-buffer))
- (save-excursion
- (set-buffer buffer)
- (when gud-minor-mode
- (setq gud-minor-mode nil)
- (kill-local-variable 'tool-bar-map))))))
+ (unless (eq buffer gud-comint-buffer)
+ (with-current-buffer buffer
+ (when gud-minor-mode
+ (setq gud-minor-mode nil)
+ (kill-local-variable 'tool-bar-map))))))
(defun gud-display-frame ()
"Find and obey the last filename-and-line marker from the debugger.
@@ -2580,7 +2587,7 @@ Obeying it means displaying in another window the specified file and line."
(with-current-buffer gud-comint-buffer
(gud-find-file true-file)))
(window (and buffer (or (get-buffer-window buffer)
- (if (eq gud-minor-mode 'gdba)
+ (if (memq gud-minor-mode '(gdbmi gdba))
(gdb-display-source-buffer buffer)
(display-buffer buffer)))))
(pos))
@@ -2704,7 +2711,7 @@ Obeying it means displaying in another window the specified file and line."
(forward-line 0)
(if (looking-at comint-prompt-regexp)
(set-marker gud-delete-prompt-marker (point)))
- (if (eq gud-minor-mode 'gdba)
+ (if (memq gud-minor-mode '(gdbmi gdba))
(apply comint-input-sender (list proc command))
(process-send-string proc (concat command "\n")))))))
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index a600939ef71..ae0c43c2730 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -1823,8 +1823,8 @@ Change the default directory for the process buffer to concur."
'hide 'wait)
;; If we don't know anything about the class, update shell routines
(if (and idlwave-shell-get-object-class
- (not (assoc-ignore-case idlwave-shell-get-object-class
- (idlwave-class-alist))))
+ (not (assoc-string idlwave-shell-get-object-class
+ (idlwave-class-alist) t)))
(idlwave-shell-maybe-update-routine-info))
idlwave-shell-get-object-class)))
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index bfa507b851a..274480a36de 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -3,6 +3,7 @@
;; Copyright (C) 2003, 04 Free Software Foundation, Inc.
;; Author: Dave Love <fx@gnu.org>
+;; Maintainer: FSF
;; Created: Nov 2003
;; Keywords: languages
@@ -45,19 +46,18 @@
;; I've installed a minor mode to do the job properly in Emacs 22.
;; Other things seem more natural or canonical here, e.g. the
;; {beginning,end}-of-defun implementation dealing with nested
-;; definitions, and the inferior mode following `cmuscheme'. (The
-;; inferior mode should be able to find the source of errors from
-;; `python-send-region' & al via `compilation-minor-mode', but I can't
-;; make that work with the current (March '04) compile.el.)
-;; Successive TABs cycle between possible indentations for the line.
+;; definitions, and the inferior mode following `cmuscheme'. The
+;; inferior mode can find the source of errors from
+;; `python-send-region' & al via `compilation-minor-mode'. Successive
+;; TABs cycle between possible indentations for the line. There is
+;; symbol completion using lookup in Python.
;; Even where it has similar facilities, this is incompatible with
;; python-mode.el in various respects. For instance, various key
;; bindings are changed to obey Emacs conventions, and things like
;; marking blocks and `beginning-of-defun' behave differently.
-;; TODO: See various Fixmes below. It should be possible to arrange
-;; some sort of completion using the inferior interpreter.
+;; TODO: See various Fixmes below.
;;; Code:
@@ -66,10 +66,8 @@
(require 'comint)
(eval-when-compile
(require 'compile)
- (autoload 'Info-last "info")
- (autoload 'Info-exit "info")
(autoload 'info-lookup-maybe-add-help "info-look"))
-(autoload 'compilation-start "compile") ; spurious compiler warning anyway
+(autoload 'compilation-start "compile")
(defgroup python nil
"Silly walks in the Python language"
@@ -204,6 +202,8 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)."
(define-key map "\C-c\C-z" 'python-switch-to-python)
(define-key map "\C-c\C-m" 'python-load-file)
(define-key map "\C-c\C-l" 'python-load-file) ; a la cmuscheme
+ (substitute-key-definition 'complete-symbol 'python-complete-symbol
+ map global-map)
;; Fixme: Add :help to menu.
(easy-menu-define python-menu map "Python Mode menu"
'("Python"
@@ -262,9 +262,7 @@ Used for syntactic keywords. N is the match number (1, 2 or 3)."
;;;; Utility stuff
(defsubst python-in-string/comment ()
- "Return non-nil if point is in a Python literal (a comment or string).
-Optional argument LIM indicates the beginning of the containing form,
-i.e. the limit on how far back to scan."
+ "Return non-nil if point is in a Python literal (a comment or string)."
(syntax-ppss-context (syntax-ppss)))
(defconst python-space-backslash-table
@@ -299,16 +297,18 @@ comments and strings, or that the bracket/paren nesting depth is nonzero."
(syntax-ppss (line-beginning-position)))))))
(defun python-comment-line-p ()
- "Return non-nil if current line has only a comment or is blank."
+ "Return non-nil iff current line has only a comment."
(save-excursion
- (back-to-indentation)
- (looking-at (rx (or (syntax comment-start) line-end)))))
+ (end-of-line)
+ (when (eq 'comment (syntax-ppss-context (syntax-ppss)))
+ (back-to-indentation)
+ (looking-at (rx (or (syntax comment-start) line-end))))))
(defun python-beginning-of-string ()
"Go to beginning of string around point.
Do nothing if not in string."
(let ((state (syntax-ppss)))
- (when (nth 3 state)
+ (when (eq 'string (syntax-ppss-context state))
(goto-char (nth 8 state)))))
(defun python-open-block-statement-p (&optional bos)
@@ -323,7 +323,8 @@ BOS non-nil means point is known to be at beginning of statement."
line-end))
(save-excursion (python-end-of-statement))
t)
- (not (python-in-string/comment)))))
+ (not (progn (goto-char (match-beginning 0))
+ (python-in-string/comment))))))
(defun python-close-block-statement-p (&optional bos)
"Return non-nil if current line is a statement closing a block.
@@ -384,7 +385,8 @@ Otherwise indent them to column zero."
(defcustom python-honour-comment-indentation nil
"Non-nil means indent relative to preceding comment line.
Only do this for comments where the leading comment character is followed
-by space."
+by space. This doesn't apply to comment lines, which are always indented
+in lines with preceding comments."
:type 'boolean
:group 'python)
@@ -514,6 +516,16 @@ Set `python-indent' locally to the value guessed."
(- python-indent)))
0)))))))))
+(defun python-comment-indent ()
+ "`comment-indent-function' for Python."
+ ;; If previous non-blank line was a comment, use its indentation.
+ ;; FIXME: This seems unnecessary since the default code delegates to
+ ;; indent-according-to-mode. --Stef
+ (unless (bobp)
+ (save-excursion
+ (forward-comment -1)
+ (if (eq ?# (char-after)) (current-column)))))
+
;;;; Cycling through the possible indentations with successive TABs.
;; These don't need to be buffer-local since they're only relevant
@@ -538,11 +550,17 @@ Set `python-indent' locally to the value guessed."
(point))))
(defun python-indentation-levels ()
- "Return a list of possible indentations for this statement.
+ "Return a list of possible indentations for this line.
Includes the default indentation and those which would close all
-enclosing blocks."
+enclosing blocks. Assumes the line has already been indented per
+`python-indent-line'. Elements of the list are actually pairs:
+\(INDENTATION . TEXT), where TEXT is the initial text of the
+corresponding block opening (or nil)."
(save-excursion
- (let ((levels (list (cons (current-indentation) nil))))
+ (let ((levels (list (cons (current-indentation)
+ (save-excursion
+ (if (python-beginning-of-block)
+ (python-initial-text)))))))
;; Only one possibility if we immediately follow a block open or
;; are in a continuation line.
(unless (or (python-continuation-line-p)
@@ -568,8 +586,7 @@ enclosing blocks."
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))))
-;; Fixme: Is the arg necessary?
-(defun python-indent-line (&optional arg)
+(defun python-indent-line ()
"Indent current line as Python code.
When invoked via `indent-for-tab-command', cycle through possible
indentations for current line. The cycle is broken by a command different
@@ -586,13 +603,30 @@ from `indent-for-tab-command', i.e. successive TABs do the cycling."
(beginning-of-line)
(delete-horizontal-space)
(indent-to (car (nth python-indent-index python-indent-list)))
- (let ((text (cdr (nth python-indent-index
- python-indent-list))))
- (if text (message "Closes: %s" text)))))
+ (if (python-block-end-p)
+ (let ((text (cdr (nth python-indent-index
+ python-indent-list))))
+ (if text
+ (message "Closes: %s" text))))))
(python-indent-line-1)
(setq python-indent-list (python-indentation-levels)
python-indent-list-length (length python-indent-list)
python-indent-index (1- python-indent-list-length)))))
+
+(defun python-block-end-p ()
+ "Non-nil if this is a line in a statement closing a block,
+or a blank line indented to where it would close a block."
+ (and (not (python-comment-line-p))
+ (or (python-close-block-statement-p t)
+ (< (current-indentation)
+ (save-excursion
+ (python-previous-statement)
+ (current-indentation))))))
+
+;; Fixme: Define an indent-region-function. It should probably leave
+;; lines alone if the indentation is already at one of the allowed
+;; levels. Otherwise, M-C-\ typically keeps indenting more deeply
+;; down a function.
;;;; Movement.
@@ -629,8 +663,7 @@ start of buffer."
"`end-of-defun-function' for Python.
Finds end of innermost nested class or method definition."
(let ((orig (point))
- (pattern (rx (and line-start (0+ space)
- (or "def" "class") space))))
+ (pattern (rx (and line-start (0+ space) (or "def" "class") space))))
;; Go to start of current block and check whether it's at top
;; level. If it is, and not a block start, look forward for
;; definition statement.
@@ -829,7 +862,8 @@ move and return nil. Otherwise return t."
Makes nested Imenu menus from nested `class' and `def' statements.
The nested menus are headed by an item referencing the outer
definition; it has a space prepended to the name so that it sorts
-first with `imenu--sort-by-name'."
+first with `imenu--sort-by-name' (though, unfortunately, sub-menus
+precede it)."
(unless (boundp 'python-recursing) ; dynamically bound below
(goto-char (point-min))) ; normal call from Imenu
(let (index-alist ; accumulated value to return
@@ -914,13 +948,20 @@ See `python-check-command' for the default."
(file-name-nondirectory name))))))))
(setq python-saved-check-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
- (compilation-start command))
+ (let ((compilation-error-regexp-alist
+ (cons '("(\\([^,]+\\), line \\([0-9]+\\))" 1 2)
+ compilation-error-regexp-alist)))
+ (compilation-start command)))
;;;; Inferior mode stuff (following cmuscheme).
+;; Fixme: Make sure we can work with IPython.
+
(defcustom python-python-command "python"
"*Shell command to run Python interpreter.
-Any arguments can't contain whitespace."
+Any arguments can't contain whitespace.
+Note that IPython may not work properly; it must at least be used with the
+`-cl' flag, i.e. use `ipython -cl'."
:group 'python
:type 'string)
@@ -937,40 +978,66 @@ Additional arguments are added when the command is used by `run-python'
et al.")
(defvar python-buffer nil
- "*The current python process buffer.
-To run multiple Python processes, start the first with \\[run-python].
-It will be in a buffer named *Python*. Rename that with
-\\[rename-buffer]. Now start a new process with \\[run-python]. It
-will be in a new buffer, named *Python*. Switch between the different
-process buffers with \\[switch-to-buffer].
-
-Commands that send text from source buffers to Python processes have
-to choose a process to send to. This is determined by global variable
-`python-buffer'. Suppose you have three inferior Pythons running:
- Buffer Process
- foo python
- bar python<2>
- *Python* python<3>
-If you do a \\[python-send-region-and-go] command on some Python source
-code, what process does it go to?
-
-- In a process buffer (foo, bar, or *Python*), send it to that process.
-- In some other buffer (e.g. a source file), send it to the process
- attached to `python-buffer'.
-Process selection is done by function `python-proc'.
-
-Whenever \\[run-python] starts a new process, it resets `python-buffer'
-to be the new process's buffer. If you only run one process, this will
-do the right thing. If you run multiple processes, you can change
-`python-buffer' to another process buffer with \\[set-variable].")
+ "The current python process buffer."
+ ;; Fixme: a single process is currently assumed, so that this doc
+ ;; is misleading.
+
+;; "*The current python process buffer.
+;; To run multiple Python processes, start the first with \\[run-python].
+;; It will be in a buffer named *Python*. Rename that with
+;; \\[rename-buffer]. Now start a new process with \\[run-python]. It
+;; will be in a new buffer, named *Python*. Switch between the different
+;; process buffers with \\[switch-to-buffer].
+
+;; Commands that send text from source buffers to Python processes have
+;; to choose a process to send to. This is determined by global variable
+;; `python-buffer'. Suppose you have three inferior Pythons running:
+;; Buffer Process
+;; foo python
+;; bar python<2>
+;; *Python* python<3>
+;; If you do a \\[python-send-region-and-go] command on some Python source
+;; code, what process does it go to?
+
+;; - In a process buffer (foo, bar, or *Python*), send it to that process.
+;; - In some other buffer (e.g. a source file), send it to the process
+;; attached to `python-buffer'.
+;; Process selection is done by function `python-proc'.
+
+;; Whenever \\[run-python] starts a new process, it resets `python-buffer'
+;; to be the new process's buffer. If you only run one process, this will
+;; do the right thing. If you run multiple processes, you can change
+;; `python-buffer' to another process buffer with \\[set-variable]."
+ )
(defconst python-compilation-regexp-alist
+ ;; FIXME: maybe these should move to compilation-error-regexp-alist-alist.
`((,(rx (and line-start (1+ (any " \t")) "File \""
(group (1+ (not (any "\"<")))) ; avoid `<stdin>' &c
"\", line " (group (1+ digit))))
- 1 python-compilation-line-number))
+ 1 2)
+ (,(rx (and " in file " (group (1+ not-newline)) " on line "
+ (group (1+ digit))))
+ 1 2))
"`compilation-error-regexp-alist' for inferior Python.")
+(defvar inferior-python-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; This will inherit from comint-mode-map.
+ (define-key map "\C-c\C-l" 'python-load-file)
+ (define-key map "\C-c\C-v" 'python-check)
+ ;; Note that we _can_ still use these commands which send to the
+ ;; Python process even at the prompt iff we have a normal prompt,
+ ;; i.e. '>>> ' and not '... '. See the comment before
+ ;; python-send-region. Fixme: uncomment these if we address that.
+
+ ;; (define-key map [(meta ?\t)] 'python-complete-symbol)
+ ;; (define-key map "\C-c\C-f" 'python-describe-symbol)
+ map))
+
+;; 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?
(define-derived-mode inferior-python-mode comint-mode "Inferior Python"
"Major mode for interacting with an inferior Python process.
A Python process can be started with \\[run-python].
@@ -991,14 +1058,13 @@ For running multiple processes in multiple buffers, see `python-buffer'.
:group 'python
(set-syntax-table python-mode-syntax-table)
(setq mode-line-process '(":%s"))
- ;; Fixme: Maybe install some python-mode bindings too.
- (define-key inferior-python-mode-map "\C-c\C-l" 'python-load-file)
- (define-key inferior-python-mode-map "\C-c\C-z" 'python-switch-to-python)
- (add-hook 'comint-input-filter-functions 'python-input-filter nil t)
+ (set (make-local-variable 'comint-input-filter) 'python-input-filter)
(add-hook 'comint-preoutput-filter-functions #'python-preoutput-filter
nil t)
- ;; Still required by `comint-redirect-send-command', for instance:
- (set (make-local-variable 'comint-prompt-regexp) "^\\([>.]\\{3\\} \\)+")
+ ;; Still required by `comint-redirect-send-command', for instance
+ ;; (and we need to match things like `>>> ... >>> '):
+ (set (make-local-variable 'comint-prompt-regexp)
+ (rx (and line-start (1+ (and (repeat 3 (any ">.")) ?\ )))))
(set (make-local-variable 'compilation-error-regexp-alist)
python-compilation-regexp-alist)
(compilation-shell-minor-mode 1))
@@ -1009,15 +1075,9 @@ Default ignores all inputs of 0, 1, or 2 non-blank characters."
:type 'regexp
:group 'python)
-(defvar python-orig-start nil
- "Marker to the start of the region passed to the inferior Python.
-It can also be a filename.")
-
(defun python-input-filter (str)
"`comint-input-filter' function for inferior Python.
-Don't save anything for STR matching `inferior-python-filter-regexp'.
-Also resets variables for adjusting error messages."
- (setq python-orig-start nil)
+Don't save anything for STR matching `inferior-python-filter-regexp'."
(not (string-match inferior-python-filter-regexp str)))
;; Fixme: Loses with quoted whitespace.
@@ -1030,21 +1090,8 @@ Also resets variables for adjusting error messages."
(t (let ((pos (string-match "[^ \t]" string)))
(if pos (python-args-to-list (substring string pos))))))))
-(defun python-compilation-line-number (file col)
- "Return error descriptor of error found for FILE, column COL.
-Used as line-number hook function in `python-compilation-regexp-alist'."
- (let ((line (string-to-number (match-string 2))))
- (cons (point-marker)
- (if (and (markerp python-orig-start)
- (marker-buffer python-orig-start))
- (with-current-buffer (marker-buffer python-orig-start)
- (goto-char python-orig-start)
- (forward-line (1- line)))
- (list (if (stringp python-orig-start) python-orig-start file)
- line nil)))))
-
(defvar python-preoutput-result nil
- "Data from output line last `_emacs_out' line seen by the preoutput filter.")
+ "Data from last `_emacs_out' line seen by the preoutput filter.")
(defvar python-preoutput-continuation nil
"If non-nil, funcall this when `python-preoutput-filter' sees `_emacs_ok'.")
@@ -1055,7 +1102,9 @@ Used as line-number hook function in `python-compilation-regexp-alist'."
;; `python-preoutput-continuation' if we get it.
(defun python-preoutput-filter (s)
"`comint-preoutput-filter-functions' function: ignore prompts not at bol."
- (cond ((and (string-match "\\`[.>]\\{3\\} \\'" s)
+ (cond ((and (string-match (rx (and string-start (repeat 3 (any ".>"))
+ " " string-end))
+ s)
(/= (let ((inhibit-field-text-motion t))
(line-beginning-position))
(point)))
@@ -1076,10 +1125,10 @@ Used as line-number hook function in `python-compilation-regexp-alist'."
CMD is the Python command to run. NOSHOW non-nil means don't show the
buffer automatically.
If there is a process already running in `*Python*', switch to
-that buffer. Interactively a prefix arg, allows you to edit the initial
-command line (default is the value of `python-command'); `-i' etc. args
-will be added to this as appropriate. Runs the hooks
-`inferior-python-mode-hook' (after the `comint-mode-hook' is run).
+that buffer. Interactively, a prefix arg allows you to edit the initial
+command line (default is `python-command'); `-i' etc. args will be added
+to this as appropriate. Runs the hook `inferior-python-mode-hook'
+\(after the `comint-mode-hook' is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(interactive (list (if current-prefix-arg
(read-string "Run Python: " python-command)
@@ -1089,82 +1138,78 @@ will be added to this as appropriate. Runs the hooks
;; Fixme: Consider making `python-buffer' buffer-local as a buffer
;; (not a name) in Python buffers from which `run-python' &c is
;; invoked. Would support multiple processes better.
- (unless (comint-check-proc "*Python*")
- (let ((cmdlist (append (python-args-to-list cmd) '("-i"))))
+ (unless (comint-check-proc python-buffer)
+ (let* ((cmdlist (append (python-args-to-list cmd) '("-i")))
+ (path (getenv "PYTHONPATH"))
+ (process-environment ; to import emacs.py
+ (push (concat "PYTHONPATH=" data-directory
+ (if path (concat ":" path)))
+ process-environment)))
(set-buffer (apply 'make-comint "Python" (car cmdlist) nil
- (cdr cmdlist))))
+ (cdr cmdlist)))
+ (setq python-buffer "*Python*"))
(inferior-python-mode)
;; Load function defintions we need.
;; Before the preoutput function was used, this was done via -c in
;; cmdlist, but that loses the banner and doesn't run the startup
- ;; file.
- (python-send-string "\
-def _emacs_execfile (file): # execute file and remove it
- from os import remove
- try: execfile (file, globals (), globals ())
- finally: remove (file)
-
-def _emacs_args (name): # get arglist of name for eldoc &c
- import inspect
- parts = name.split ('.')
- if len (parts) > 1:
- try: exec 'import ' + parts[0]
- except: return None
- try: exec 'func='+name # lose if name is keyword or undefined
- except: return None
- if inspect.isbuiltin (func):
- doc = func.__doc__
- if doc.find (' ->') != -1:
- print '_emacs_out', doc.split (' ->')[0]
- elif doc.find ('\\n') != -1:
- print '_emacs_out', doc.split ('\\n')[0]
- return None
- if inspect.ismethod (func): func = func.im_func
- if not inspect.isfunction (func):
- return None
- (args, varargs, varkw, defaults) = inspect.getargspec (func)
- print '_emacs_out', func.__name__+inspect.formatargspec (args, varargs, varkw, defaults)
-
-print '_emacs_ok'"))
- (unless noshow (pop-to-buffer (setq python-buffer "*Python*"))))
+ ;; file. The code might be inline here, but there's enough that it
+ ;; seems worth putting in a separate file, and it's probably cleaner
+ ;; to put it in a module.
+ (python-send-string "import emacs"))
+ (unless noshow (pop-to-buffer python-buffer)))
+
+;; Fixme: We typically lose if the inferior isn't in the normal REPL,
+;; e.g. prompt is `help> '. Probably raise an error if the form of
+;; the prompt is unexpected; actually, it needs to be `>>> ', not
+;; `... ', i.e. we're not inputting a block &c. However, this may not
+;; be the place to do it, e.g. we might actually want to send commands
+;; having set up such a state.
+
+(defun python-send-command (command)
+ "Like `python-send-string' but resets `compilation-minor-mode'."
+ (goto-char (point-max))
+ (let ((end (marker-position (process-mark (python-proc)))))
+ (compilation-forget-errors)
+ (python-send-string command)
+ (set-marker compilation-parsing-end end)
+ (setq compilation-last-buffer (current-buffer))))
(defun python-send-region (start end)
"Send the region to the inferior Python process."
;; The region is evaluated from a temporary file. This avoids
;; problems with blank lines, which have different semantics
;; interactively and in files. It also saves the inferior process
- ;; buffer filling up with interpreter prompts. We need a function
- ;; to remove the temporary file when it has been evaluated, which
- ;; unfortunately means using a not-quite pristine interpreter
- ;; initially. Unfortunately we also get tracebacks which look like:
- ;;
- ;; >>> Traceback (most recent call last):
- ;; File "<stdin>", line 1, in ?
- ;; File "<string>", line 4, in _emacs_execfile
- ;; File "/tmp/py7734RSB", line 11
+ ;; buffer filling up with interpreter prompts. We need a Python
+ ;; function to remove the temporary file when it has been evaluated
+ ;; (though we could probably do it in Lisp with a Comint output
+ ;; filter). This function also catches exceptions and truncates
+ ;; tracebacks not to mention the frame of the function itself.
;;
;; The compilation-minor-mode parsing takes care of relating the
- ;; reference to the temporary file to the source. Fixme:
- ;; comint-filter the first two lines of the traceback?
+ ;; reference to the temporary file to the source.
+ ;;
+ ;; Fixme: Write a `coding' header to the temp file if the region is
+ ;; non-ASCII.
(interactive "r")
(let* ((f (make-temp-file "py"))
- (command (format "_emacs_execfile(%S)" f))
+ (command (format "emacs.eexecfile(%S)" f))
(orig-start (copy-marker start)))
- (if (save-excursion
- (goto-char start)
- (/= 0 (current-indentation))) ; need dummy block
- (write-region "if True:\n" nil f nil 'nomsg))
+ (when (save-excursion
+ (goto-char start)
+ (/= 0 (current-indentation))) ; need dummy block
+ (save-excursion
+ (goto-char orig-start)
+ ;; Wrong if we had indented code at buffer start.
+ (set-marker orig-start (line-beginning-position 0)))
+ (write-region "if True:\n" nil f nil 'nomsg))
(write-region start end f t 'nomsg)
- (when python-buffer
+ (let ((proc (python-proc))) ;Make sure we're running a process.
(with-current-buffer python-buffer
- (let ((end (marker-position (process-mark (python-proc)))))
- (set (make-local-variable 'python-orig-start) orig-start)
- (set (make-local-variable 'compilation-error-list) nil)
- (let ((comint-input-filter-functions
- (delete 'python-input-filter comint-input-filter-functions)))
- (python-send-string command))
- (set-marker compilation-parsing-end end)
- (setq compilation-last-buffer (current-buffer)))))))
+ (python-send-command command)
+ ;; Tell compile.el to redirect error locations in file `f' to
+ ;; positions past marker `orig-start'. It has to be done *after*
+ ;; python-send-command's call to compilation-forget-errors.
+ (compilation-fake-loc orig-start f)))))
(defun python-send-string (string)
"Evaluate STRING in inferior Python process."
@@ -1177,6 +1222,8 @@ print '_emacs_ok'"))
(interactive)
(python-send-region (point-min) (point-max)))
+;; Fixme: Try to define the function or class within the relevant
+;; module, not just at top level.
(defun python-send-defun ()
"Send the current defun (class or method) to the inferior Python process."
(interactive)
@@ -1223,39 +1270,33 @@ function location information for debugging, and supports users of
module-qualified names."
(interactive (comint-get-source "Load Python file: " python-prev-dir/file
python-source-modes
- t)) ; because execfile needs exact name
- (comint-check-source file-name) ; Check to see if buffer needs saved.
+ t)) ; because execfile needs exact name
+ (comint-check-source file-name) ; Check to see if buffer needs saving.
(setq python-prev-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
- (when python-buffer
+ (let ((proc (python-proc))) ;Make sure we have a process.
(with-current-buffer python-buffer
- (let ((end (marker-position (process-mark (python-proc)))))
- (set (make-local-variable 'compilation-error-list) nil)
- ;; (set (make-local-variable 'compilation-old-error-list) nil)
- (let ((comint-input-filter-functions
- (delete 'python-input-filter comint-input-filter-functions)))
- (python-send-string
- (if (string-match "\\.py\\'" file-name)
- ;; Fixme: make sure the directory is in the path list
- (let ((module (file-name-sans-extension
- (file-name-nondirectory file-name))))
- (set (make-local-variable 'python-orig-start) nil)
- (format "\
-if globals().has_key(%S): reload(%s)
-else: import %s
-" module module module))
- (set (make-local-variable 'python-orig-start) file-name)
- (format "execfile('%s')" file-name))))
- (set-marker compilation-parsing-end end)
- (setq compilation-last-buffer (current-buffer))))))
-
-;; Fixme: Should this start a process if there isn't one? (Unlike cmuscheme.)
+ ;; Fixme: I'm not convinced by this logic from python-mode.el.
+ (python-send-command
+ (if (string-match "\\.py\\'" file-name)
+ (let ((module (file-name-sans-extension
+ (file-name-nondirectory file-name))))
+ (format "emacs.eimport(%S,%S)"
+ module (file-name-directory file-name)))
+ (format "execfile(%S)" file-name)))
+ (message "%s loaded" file-name))))
+
+;; Fixme: If we need to start the process, wait until we've got the OK
+;; from the startup.
(defun python-proc ()
- "Return the current Python process. See variable `python-buffer'."
- (let ((proc (get-buffer-process (if (eq major-mode 'inferior-python-mode)
- (current-buffer)
- python-buffer))))
- (or proc (error "No current process. See variable `python-buffer'"))))
+ "Return the current Python process.
+See variable `python-buffer'. Starts a new process if necessary."
+ (or (if python-buffer
+ (get-buffer-process (if (eq major-mode 'inferior-python-mode)
+ (current-buffer)
+ python-buffer)))
+ (progn (run-python nil t)
+ (python-proc))))
;;;; Context-sensitive help.
@@ -1267,33 +1308,47 @@ else: import %s
"Syntax table giving `.' symbol syntax.
Otherwise inherits from `python-mode-syntax-table'.")
+(defvar view-return-to-alist)
+(eval-when-compile (autoload 'help-buffer "help-fns"))
+
;; Fixme: Should this actually be used instead of info-look, i.e. be
-;; bound to C-h S?
+;; bound to C-h S? Can we use other pydoc stuff before python 2.2?
(defun python-describe-symbol (symbol)
- "Get help on SYMBOL using `pydoc'.
-Interactively, prompt for symbol."
- ;; Note that we do this in the inferior process, not a separate one to
+ "Get help on SYMBOL using `help'.
+Interactively, prompt for symbol.
+
+Symbol may be anything recognized by the interpreter's `help' command --
+e.g. `CALLS' -- not just variables in scope.
+This only works for Python version 2.2 or newer since earlier interpreters
+don't support `help'."
+ ;; Note that we do this in the inferior process, not a separate one, to
;; ensure the environment is appropriate.
(interactive
(let ((symbol (with-syntax-table python-dotty-syntax-table
(current-word)))
- (enable-recursive-minibuffers t)
- val)
- (setq val (read-string (if symbol
- (format "Describe symbol (default %s): "
- symbol)
- "Describe symbol: ")
- nil nil symbol))
- (list (or val symbol))))
+ (enable-recursive-minibuffers t))
+ (list (read-string (if symbol
+ (format "Describe symbol (default %s): " symbol)
+ "Describe symbol: ")
+ nil nil symbol))))
(if (equal symbol "") (error "No symbol"))
(let* ((func `(lambda ()
- (comint-redirect-send-command (format "help(%S)\n" ,symbol)
+ (comint-redirect-send-command (format "emacs.ehelp(%S)\n"
+ ,symbol)
"*Help*" nil))))
;; Ensure we have a suitable help buffer.
- (let (temp-buffer-show-hook) ; avoid xref stuff
- (with-output-to-temp-buffer "*Help*"
+ ;; Fixme: Maybe process `Related help topics' a la help xrefs and
+ ;; allow C-c C-f in help buffer.
+ (let ((temp-buffer-show-hook ; avoid xref stuff
+ (lambda ()
+ (toggle-read-only 1)
+ (setq view-return-to-alist
+ (list (cons (selected-window) help-return-method))))))
+ (help-setup-xref (list 'python-describe-symbol symbol) (interactive-p))
+ (with-output-to-temp-buffer (help-buffer)
(with-current-buffer standard-output
- (set (make-local-variable 'comint-redirect-subvert-readonly) t))))
+ (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+ (print-help-return-message))))
(if (and python-buffer (get-buffer python-buffer))
(with-current-buffer python-buffer
(funcall func))
@@ -1302,6 +1357,15 @@ Interactively, prompt for symbol."
(add-to-list 'debug-ignored-errors "^No symbol")
+(defun python-send-receive (string)
+ "Send STRING to inferior Python (if any) and return result.
+The result is what follows `_emacs_out' in the output (or nil)."
+ (let ((proc (python-proc)))
+ (python-send-string string)
+ (setq python-preoutput-result nil)
+ (accept-process-output proc 5)
+ python-preoutput-result))
+
;; Fixme: try to make it work with point in the arglist. Also, is
;; there anything reasonable we can do with random methods?
;; (Currently only works with functions.)
@@ -1310,14 +1374,9 @@ Interactively, prompt for symbol."
Only works when point is in a function name, not its arglist, for instance.
Assumes an inferior Python is running."
(let ((symbol (with-syntax-table python-dotty-syntax-table
- (current-word)))
- (proc (and python-buffer (python-proc))))
- (when (and proc symbol)
- (python-send-string
- (format "_emacs_args(%S)" symbol))
- (setq python-preoutput-result nil)
- (accept-process-output proc 1)
- python-preoutput-result)))
+ (current-word))))
+ (when symbol
+ (python-send-receive (format "emacs.eargs(%S)" symbol)))))
;;;; Info-look functionality.
@@ -1331,11 +1390,13 @@ Used with `eval-after-load'."
;; Whether info files have a Python version suffix, e.g. in Debian.
(versioned
(with-temp-buffer
- (Info-mode)
+ (with-no-warnings (Info-mode))
(condition-case ()
;; Don't use `info' because it would pop-up a *info* buffer.
- (Info-goto-node (format "(python%s-lib)Miscellaneous Index"
- version))
+ (with-no-warnings
+ (Info-goto-node (format "(python%s-lib)Miscellaneous Index"
+ version))
+ t)
(error nil)))))
(info-lookup-maybe-add-help
:mode 'python-mode
@@ -1401,7 +1462,7 @@ The criterion is either a match for `jython-mode' via
(while (re-search-forward
(rx (and line-start (or "import" "from") (1+ space)
(group (1+ (not (any " \t\n."))))))
- 10000 ; Probably not worth customizing.
+ (+ (point-min) 10000) ; Probably not worth customizing.
t)
(if (member (match-string 1) python-jython-packages)
(throw 'done t))))
@@ -1519,11 +1580,97 @@ Uses `python-beginning-of-block', `python-end-of-block'."
(python-end-of-block)
(exchange-point-and-mark))
+;;;; Completion.
+
+(defun python-symbol-completions (symbol)
+ "Return a list of completions of the string SYMBOL from Python process.
+The list is sorted."
+ (when symbol
+ (let ((completions
+ (condition-case ()
+ (car (read-from-string (python-send-receive
+ (format "emacs.complete(%S)" symbol))))
+ (error nil))))
+ (sort
+ ;; We can get duplicates from the above -- don't know why.
+ (delete-dups completions)
+ #'string<))))
+
+(defun python-partial-symbol ()
+ "Return the partial symbol before point (for completion)."
+ (let ((end (point))
+ (start (save-excursion
+ (and (re-search-backward
+ (rx (and (or buffer-start (regexp "[^[:alnum:]._]"))
+ (group (1+ (regexp "[[:alnum:]._]")))
+ point))
+ nil t)
+ (match-beginning 1)))))
+ (if start (buffer-substring-no-properties start end))))
+
+;; Fixme: We should have an abstraction of this sort of thing in the
+;; core.
+(defun python-complete-symbol ()
+ "Perform completion on the Python symbol preceding point.
+Repeating the command scrolls the completion window."
+ (interactive)
+ (let ((window (get-buffer-window "*Completions*")))
+ (if (and (eq last-command this-command)
+ window (window-live-p window) (window-buffer window)
+ (buffer-name (window-buffer window)))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ (set-window-start window (point-min))
+ (save-selected-window
+ (select-window window)
+ (scroll-up))))
+ ;; Do completion.
+ (let* ((end (point))
+ (symbol (python-partial-symbol))
+ (completions (python-symbol-completions symbol))
+ (completion (if completions
+ (try-completion symbol completions))))
+ (when symbol
+ (cond ((eq completion t))
+ ((null completion)
+ (message "Can't find completion for \"%s\"" symbol)
+ (ding))
+ ((not (string= symbol completion))
+ (delete-region (- end (length symbol)) end)
+ (insert completion))
+ (t
+ (message "Making completion list...")
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list completions))
+ (message "Making completion list...%s" "done"))))))))
+
+(eval-when-compile (require 'hippie-exp))
+
+(defun python-try-complete (old)
+ "Completion function for Python for use with `hippie-expand'."
+ (when (eq major-mode 'python-mode) ; though we only add it locally
+ (unless old
+ (let ((symbol (python-partial-symbol)))
+ (he-init-string (- (point) (length symbol)) (point))
+ (if (not (he-string-member he-search-string he-tried-table))
+ (push he-search-string he-tried-table))
+ (setq he-expand-list
+ (and symbol (python-symbol-completions symbol)))))
+ (while (and he-expand-list
+ (he-string-member (car he-expand-list) he-tried-table))
+ (pop he-expand-list))
+ (if he-expand-list
+ (progn
+ (he-substitute-string (pop he-expand-list))
+ t)
+ (if old (he-reset-string))
+ nil)))
+
;;;; Modes.
(defvar outline-heading-end-regexp)
(defvar eldoc-print-current-symbol-info-function)
-(defvar python-mode-running)
+
;;;###autoload
(define-derived-mode python-mode fundamental-mode "Python"
"Major mode for editing Python files.
@@ -1565,11 +1712,10 @@ lines count as headers.
))
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(set (make-local-variable 'comment-start) "# ")
- ;; Fixme: define a comment-indent-function?
+ (set (make-local-variable 'comment-indent-function) #'python-comment-indent)
(set (make-local-variable 'indent-line-function) #'python-indent-line)
(set (make-local-variable 'paragraph-start) "\\s-*$")
- (set (make-local-variable 'fill-paragraph-function)
- 'python-fill-paragraph)
+ (set (make-local-variable 'fill-paragraph-function) 'python-fill-paragraph)
(set (make-local-variable 'require-final-newline) t)
(set (make-local-variable 'add-log-current-defun-function)
#'python-current-defun)
@@ -1587,6 +1733,9 @@ lines count as headers.
#'python-eldoc-function)
(add-hook 'eldoc-mode-hook
'(lambda () (run-python 0 t)) nil t) ; need it running
+ (if (featurep 'hippie-exp)
+ (set (make-local-variable 'hippie-expand-try-functions-list)
+ (cons 'python-try-complete hippie-expand-try-functions-list)))
(unless font-lock-mode (font-lock-mode 1))
(when python-guess-indent (python-guess-indent))
(set (make-local-variable 'python-command) python-python-command)
diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el
index df2bf6803da..adb5f7b402a 100644
--- a/lisp/progmodes/sh-script.el
+++ b/lisp/progmodes/sh-script.el
@@ -648,7 +648,7 @@ implemented as aliases. See `sh-feature'."
(rc "else")
- (sh "do" "elif" "else" "if" "then" "trap" "type" "until" "while"))
+ (sh "!" "do" "elif" "else" "if" "then" "trap" "type" "until" "while"))
"*List of keywords that may be immediately followed by a builtin or keyword.
Given some confusion between keywords and builtins depending on shell and
system, the distinction here has been based on whether they influence the
diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el
index 1a9251599ce..0e0d89b07e1 100644
--- a/lisp/progmodes/sql.el
+++ b/lisp/progmodes/sql.el
@@ -1,11 +1,12 @@
;;; sql.el --- specialized comint.el for SQL interpreters
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1998,99,2000,01,02,03,04 Free Software Foundation, Inc.
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Michael Mauger <mmaug@yahoo.com>
-;; Version: 1.8.0
+;; Version: 2.0.1
;; Keywords: comm languages processes
+;; URL: http://savannah.gnu.org/cgi-bin/viewcvs/emacs/emacs/lisp/progmodes/sql.el
;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?SqlMode
;; This file is part of GNU Emacs.
@@ -101,7 +102,7 @@
;; (const :tag "XyzDB" xyz)
-;; 2) Add an entry to the `sql-product-support' list.
+;; 2) Add an entry to the `sql-product-alist' list.
;; (xyz
;; :font-lock sql-mode-xyz-font-lock-keywords
@@ -136,7 +137,7 @@
;; using ANSI keywords. See sql-mode-oracle-font-lock-keywords for
;; a more complex example.
-;; (defvar sql-mode-xyz-font-lock-keywords sql-mode-ansi-font-lock-keywords
+;; (defvar sql-mode-xyz-font-lock-keywords nil
;; "XyzDB SQL keywords used by font-lock.")
;; 6) Add a product highlighting function.
@@ -192,13 +193,18 @@
;;; Thanks to all the people who helped me out:
+;; Alex Schroeder <alex@gnu.org>
;; Kai Blauberg <kai.blauberg@metla.fi>
;; <ibalaban@dalet.com>
;; Yair Friedman <yfriedma@JohnBryce.Co.Il>
;; Gregor Zych <zych@pool.informatik.rwth-aachen.de>
;; nino <nino@inform.dk>
;; Berend de Boer <berend@pobox.com>
-;; Michael Mauger <mmaug@yahoo.com>
+;; Adam Jenkins <adam@thejenkins.org>
+;; Michael Mauger <mmaug@yahoo.com> -- improved product support
+;; Drew Adams <drew.adams@oracle.com> -- Emacs 20 support
+;; Harald Maier <maierh@myself.com> -- sql-send-string
+;; Stefan Monnier <monnier@iro.umontreal.ca> -- font-lock corrections
@@ -209,6 +215,8 @@
(eval-when-compile
(require 'regexp-opt))
(require 'custom)
+(eval-when-compile ;; needed in Emacs 19, 20
+ (setq max-specpdl-size 2000))
;;; Allow customization
@@ -264,7 +272,7 @@ highlighted properly when you open them."
(defvar sql-interactive-product nil
"Product under `sql-interactive-mode'.")
-(defvar sql-product-support
+(defvar sql-product-alist
'((ansi
:font-lock sql-mode-ansi-font-lock-keywords)
(db2
@@ -319,9 +327,9 @@ highlighted properly when you open them."
:syntax-alist ((?$ . "w") (?# . "w")))
(postgres
:font-lock sql-mode-postgres-font-lock-keywords
- :sqli-login (database server)
+ :sqli-login (user database server)
:sqli-connect sql-connect-postgres
- :sqli-prompt-regexp "^.*> *"
+ :sqli-prompt-regexp "^.*[#>] *"
:sqli-prompt-length 5)
(solid
:font-lock sql-mode-solid-font-lock-keywords
@@ -372,10 +380,12 @@ following:
database. Do product specific
configuration of comint in this function.
- :sqli-prompt-regexp a regular expression string that matches the
- prompt issued by the product interpreter.
+ :sqli-prompt-regexp a regular expression string that matches
+ the prompt issued by the product
+ interpreter. (Not needed in 21.3+)
- :sqli-prompt-length the length of the prompt on the line.
+ :sqli-prompt-length the length of the prompt on the line.(Not
+ needed in 21.3+)
:syntax-alist an alist of syntax table entries to enable
special character treatment by font-lock and
@@ -412,14 +422,14 @@ buffer is shown using `display-buffer'."
(defvar sql-imenu-generic-expression
;; Items are in reverse order because they are rendered in reverse.
- '(("Rules/Defaults" "^\\s-*create\\s-+\\(rule\\|default\\)\\s-+\\(\\w+\\)" 2)
- ("Sequences" "^\\s-*create\\s-+sequence\\s-+\\(\\w+\\)" 1)
- ("Triggers" "^\\s-*\\(create\\s-+\\(or\\s-+replace\\s-+\\)?\\)?trigger\\s-+\\(\\w+\\)" 3)
- ("Functions" "^\\s-*\\(create\\s-+\\(or\\s-+replace\\s-+\\)?\\)?function\\s-+\\(\\w+\\)" 3)
- ("Procedures" "^\\s-*\\(create\\s-+\\(or\\s-+replace\\s-+\\)?\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4)
- ("Packages" "^\\s-*create\\s-+\\(or\\s-+replace\\s-+\\)?package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3)
- ("Indexes" "^\\s-*create\\s-+index\\s-+\\(\\w+\\)" 1)
- ("Tables/Views" "^\\s-*create\\s-+\\(\\(global\\s-+\\)?\\(temporary\\s-+\\)?table\\|view\\)\\s-+\\(\\w+\\)" 4))
+ '(("Rules/Defaults" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(rule\\|default\\)\\s-+\\(\\w+\\)" 3)
+ ("Sequences" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*sequence\\s-+\\(\\w+\\)" 2)
+ ("Triggers" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*trigger\\s-+\\(\\w+\\)" 2)
+ ("Functions" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?function\\s-+\\(\\w+\\)" 3)
+ ("Procedures" "^\\s-*\\(create\\s-+\\(\\w+\\s-+\\)*\\)?proc\\(edure\\)?\\s-+\\(\\w+\\)" 4)
+ ("Packages" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*package\\s-+\\(body\\s-+\\)?\\(\\w+\\)" 3)
+ ("Indexes" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*index\\s-+\\(\\w+\\)" 2)
+ ("Tables/Views" "^\\s-*create\\s-+\\(\\w+\\s-+\\)*\\(table\\|view\\)\\s-+\\(\\w+\\)" 3))
"Define interesting points in the SQL buffer for `imenu'.
This is used to set `imenu-generic-expression' when SQL mode is
@@ -745,6 +755,7 @@ Based on `comint-mode-map'.")
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-c C-c") 'sql-send-paragraph)
(define-key map (kbd "C-c C-r") 'sql-send-region)
+ (define-key map (kbd "C-c C-s") 'sql-send-string)
(define-key map (kbd "C-c C-b") 'sql-send-buffer)
map)
"Mode map used for `sql-mode'.")
@@ -764,6 +775,7 @@ Based on `comint-mode-map'.")
(get-buffer-process sql-buffer))]
["Send Buffer" sql-send-buffer (and (buffer-live-p sql-buffer)
(get-buffer-process sql-buffer))]
+ ["Send String" sql-send-string t]
["--" nil nil]
["Start SQLi session" sql-product-interactive (sql-product-feature :sqli-connect)]
["Show SQLi buffer" sql-show-sqli-buffer t]
@@ -792,7 +804,7 @@ Based on `comint-mode-map'.")
["Linter" sql-highlight-linter-keywords
:style radio
:selected (eq sql-product 'linter)]
- ["Microsoft" sql-highlight-ms-keywords
+ ["MS SQLServer" sql-highlight-ms-keywords
:style radio
:selected (eq sql-product 'ms)]
["MySQL" sql-highlight-mysql-keywords
@@ -828,24 +840,24 @@ Based on `comint-mode-map'.")
(defvar sql-mode-abbrev-table nil
"Abbrev table used in `sql-mode' and `sql-interactive-mode'.")
-(if sql-mode-abbrev-table
- ()
- (let ((nargs (cdr (subr-arity (symbol-function 'define-abbrev))))
- d-a)
+(unless sql-mode-abbrev-table
+ (define-abbrev-table 'sql-mode-abbrev-table nil)
+ (mapcar
;; In Emacs 21.3+, provide SYSTEM-FLAG to define-abbrev.
- (setq d-a
- (if (>= nargs 6)
- '(lambda (name expansion) (define-abbrev sql-mode-abbrev-table name expansion nil 0 t))
- '(lambda (name expansion) (define-abbrev sql-mode-abbrev-table name expansion))))
-
- (define-abbrev-table 'sql-mode-abbrev-table nil)
- (funcall d-a "ins" "insert")
- (funcall d-a "upd" "update")
- (funcall d-a "del" "delete")
- (funcall d-a "sel" "select")
- (funcall d-a "proc" "procedure")
- (funcall d-a "func" "function")
- (funcall d-a "cr" "create")))
+ '(lambda (abbrev)
+ (let ((name (car abbrev))
+ (expansion (cdr abbrev)))
+ (condition-case nil
+ (define-abbrev sql-mode-abbrev-table name expansion nil 0 t)
+ (error
+ (define-abbrev sql-mode-abbrev-table name expansion)))))
+ '(("ins" "insert")
+ ("upd" "update")
+ ("del" "delete")
+ ("sel" "select")
+ ("proc" "procedure")
+ ("func" "function")
+ ("cr" "create"))))
;; Syntax Table
@@ -855,9 +867,7 @@ Based on `comint-mode-map'.")
(modify-syntax-entry ?/ ". 14" table)
(modify-syntax-entry ?* ". 23" table)
;; double-dash starts comment
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- (modify-syntax-entry ?- ". 56" table)
- (modify-syntax-entry ?- ". 12b" table))
+ (modify-syntax-entry ?- ". 12b" table)
;; newline and formfeed end coments
(modify-syntax-entry ?\n "> b" table)
(modify-syntax-entry ?\f "> b" table)
@@ -871,55 +881,117 @@ Based on `comint-mode-map'.")
;; Font lock support
(defvar sql-mode-font-lock-object-name
- (list (concat "^\\s-*\\(create\\(\\s-+or\\s-+replace\\)?\\|drop\\|alter\\)?\\s-+"
- "\\(\\(global\\s-+\\)?\\(temporary\\s-+\\)?table\\|view\\|package\\(\\s-+body\\)?\\|"
- "proc\\(edure\\)?\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+\\(\\w+\\)")
- 8 'font-lock-function-name-face)
-
- "Pattern to match the names of top-level objects in a CREATE,
-DROP or ALTER statement.
-
-The format of variable should be a valid `font-lock-keywords'
-entry.")
+ (list (concat "^\\s-*\\(create\\|drop\\|alter\\)\\s-+" ;; lead off with CREATE, DROP or ALTER
+ "\\(\\w+\\s-+\\)*" ;; optional intervening keywords
+ "\\(table\\|view\\|package\\(\\s-+body\\)?\\|proc\\(edure\\)?"
+ "\\|function\\|trigger\\|sequence\\|rule\\|default\\)\\s-+"
+ "\\(\\w+\\)")
+ 6 'font-lock-function-name-face)
+
+ "Pattern to match the names of top-level objects.
+
+The pattern matches the name in a CREATE, DROP or ALTER
+statement. The format of variable should be a valid
+`font-lock-keywords' entry.")
+
+(defmacro sql-keywords-re (&rest keywords)
+ "Compile-time generation of regexp matching any one of KEYWORDS."
+ `(eval-when-compile
+ (concat "\\b"
+ (regexp-opt ',keywords t)
+ "\\b")))
(defvar sql-mode-ansi-font-lock-keywords
- (let ((ansi-keywords (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
-"authorization" "avg" "begin" "close" "cobol" "commit"
-"continue" "count" "declare" "double" "end" "escape"
-"exec" "fetch" "foreign" "fortran" "found" "go" "goto" "indicator"
-"key" "language" "max" "min" "module" "numeric" "open" "pascal" "pli"
-"precision" "primary" "procedure" "references" "rollback"
-"schema" "section" "some" "sqlcode" "sqlerror" "sum" "work"
-
-) t) "\\b")))
- (ansi-reserved-words (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
-"all" "and" "any" "as" "asc" "between" "by" "check" "create"
-"current" "default" "delete" "desc" "distinct" "exists" "float" "for"
-"from" "grant" "group" "having" "in" "insert" "into" "is"
-"like" "not" "null" "of" "on" "option" "or" "order" "privileges"
-"public" "select" "set" "table" "to" "union" "unique"
-"update" "user" "values" "view" "where" "with"
-
-) t) "\\b")))
- (ansi-types (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
-;; ANSI Keywords that look like types
-"character" "cursor" "dec" "int" "real"
-;; ANSI Reserved Word that look like types
-"char" "integer" "smallint"
-
-) t) "\\b"))))
- (list (cons ansi-keywords 'font-lock-keyword-face)
- (cons ansi-reserved-words 'font-lock-keyword-face)
- (cons ansi-types 'font-lock-type-face)))
+ (let ((ansi-funcs (sql-keywords-re
+"abs" "avg" "bit_length" "cardinality" "cast" "char_length"
+"character_length" "coalesce" "convert" "count" "current_date"
+"current_path" "current_role" "current_time" "current_timestamp"
+"current_user" "extract" "localtime" "localtimestamp" "lower" "max"
+"min" "mod" "nullif" "octet_length" "overlay" "placing" "session_user"
+"substring" "sum" "system_user" "translate" "treat" "trim" "upper"
+"user"
+))
+
+ (ansi-non-reserved (sql-keywords-re
+"ada" "asensitive" "assignment" "asymmetric" "atomic" "between"
+"bitvar" "called" "catalog_name" "chain" "character_set_catalog"
+"character_set_name" "character_set_schema" "checked" "class_origin"
+"cobol" "collation_catalog" "collation_name" "collation_schema"
+"column_name" "command_function" "command_function_code" "committed"
+"condition_number" "connection_name" "constraint_catalog"
+"constraint_name" "constraint_schema" "contains" "cursor_name"
+"datetime_interval_code" "datetime_interval_precision" "defined"
+"definer" "dispatch" "dynamic_function" "dynamic_function_code"
+"existing" "exists" "final" "fortran" "generated" "granted"
+"hierarchy" "hold" "implementation" "infix" "insensitive" "instance"
+"instantiable" "invoker" "key_member" "key_type" "length" "m"
+"message_length" "message_octet_length" "message_text" "method" "more"
+"mumps" "name" "nullable" "number" "options" "overlaps" "overriding"
+"parameter_mode" "parameter_name" "parameter_ordinal_position"
+"parameter_specific_catalog" "parameter_specific_name"
+"parameter_specific_schema" "pascal" "pli" "position" "repeatable"
+"returned_length" "returned_octet_length" "returned_sqlstate"
+"routine_catalog" "routine_name" "routine_schema" "row_count" "scale"
+"schema_name" "security" "self" "sensitive" "serializable"
+"server_name" "similar" "simple" "source" "specific_name" "style"
+"subclass_origin" "sublist" "symmetric" "system" "table_name"
+"transaction_active" "transactions_committed"
+"transactions_rolled_back" "transform" "transforms" "trigger_catalog"
+"trigger_name" "trigger_schema" "type" "uncommitted" "unnamed"
+"user_defined_type_catalog" "user_defined_type_name"
+"user_defined_type_schema"
+))
+
+ (ansi-reserved (sql-keywords-re
+"absolute" "action" "add" "admin" "after" "aggregate" "alias" "all"
+"allocate" "alter" "and" "any" "are" "as" "asc" "assertion" "at"
+"authorization" "before" "begin" "both" "breadth" "by" "call"
+"cascade" "cascaded" "case" "catalog" "check" "class" "close"
+"collate" "collation" "column" "commit" "completion" "connect"
+"connection" "constraint" "constraints" "constructor" "continue"
+"corresponding" "create" "cross" "cube" "current" "cursor" "cycle"
+"data" "day" "deallocate" "declare" "default" "deferrable" "deferred"
+"delete" "depth" "deref" "desc" "describe" "descriptor" "destroy"
+"destructor" "deterministic" "diagnostics" "dictionary" "disconnect"
+"distinct" "domain" "drop" "dynamic" "each" "else" "end" "equals"
+"escape" "every" "except" "exception" "exec" "execute" "external"
+"false" "fetch" "first" "for" "foreign" "found" "free" "from" "full"
+"function" "general" "get" "global" "go" "goto" "grant" "group"
+"grouping" "having" "host" "hour" "identity" "ignore" "immediate" "in"
+"indicator" "initialize" "initially" "inner" "inout" "input" "insert"
+"intersect" "into" "is" "isolation" "iterate" "join" "key" "language"
+"last" "lateral" "leading" "left" "less" "level" "like" "limit"
+"local" "locator" "map" "match" "minute" "modifies" "modify" "module"
+"month" "names" "natural" "new" "next" "no" "none" "not" "null" "of"
+"off" "old" "on" "only" "open" "operation" "option" "or" "order"
+"ordinality" "out" "outer" "output" "pad" "parameter" "parameters"
+"partial" "path" "postfix" "prefix" "preorder" "prepare" "preserve"
+"primary" "prior" "privileges" "procedure" "public" "read" "reads"
+"recursive" "references" "referencing" "relative" "restrict" "result"
+"return" "returns" "revoke" "right" "role" "rollback" "rollup"
+"routine" "rows" "savepoint" "schema" "scroll" "search" "second"
+"section" "select" "sequence" "session" "set" "sets" "size" "some"
+"space" "specific" "specifictype" "sql" "sqlexception" "sqlstate"
+"sqlwarning" "start" "state" "statement" "static" "structure" "table"
+"temporary" "terminate" "than" "then" "timezone_hour"
+"timezone_minute" "to" "trailing" "transaction" "translation"
+"trigger" "true" "under" "union" "unique" "unknown" "unnest" "update"
+"usage" "using" "value" "values" "variable" "view" "when" "whenever"
+"where" "with" "without" "work" "write" "year"
+))
+
+ (ansi-types (sql-keywords-re
+"array" "binary" "bit" "blob" "boolean" "char" "character" "clob"
+"date" "dec" "decimal" "double" "float" "int" "integer" "interval"
+"large" "national" "nchar" "nclob" "numeric" "object" "precision"
+"real" "ref" "row" "scope" "smallint" "time" "timestamp" "varchar"
+"varying" "zone"
+)))
+
+ `((,ansi-non-reserved . font-lock-keyword-face)
+ (,ansi-reserved . font-lock-keyword-face)
+ (,ansi-funcs . font-lock-builtin-face)
+ (,ansi-types . font-lock-type-face)))
"ANSI SQL keywords used by font-lock.
@@ -930,66 +1002,156 @@ you define your own sql-mode-ansi-font-lock-keywords. You may want to
add functions and PL/SQL keywords.")
(defvar sql-mode-oracle-font-lock-keywords
- (let ((oracle-keywords (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; Oracle (+ANSI) SQL keywords
-
-; ANSI keywords
-"authorization" "avg" "begin" "close" "cobol" "commit"
-"continue" "count" "declare" "double" "end" "escape"
-"exec" "fetch" "foreign" "fortran" "found" "go" "goto" "indicator"
-"key" "language" "max" "min" "module" "numeric" "open" "pascal" "pli"
-"precision" "primary" "procedure" "references" "rollback"
-"schema" "section" "some" "sqlcode" "sqlerror" "sum" "work"
-
-; ANSI reserved words
-"all" "and" "any" "as" "asc" "between" "by" "check" "create"
-"current" "default" "delete" "desc" "distinct" "exists" "float" "for"
-"from" "grant" "group" "having" "in" "insert" "into" "is"
-"like" "not" "null" "of" "on" "option" "or" "order" "privileges"
-"public" "select" "set" "table" "to" "union" "unique"
-"update" "user" "values" "view" "where" "with"
-
-"access" "add" "admin" "after" "allocate" "alter" "analyze" "archive"
-"archivelog" "audit" "authid" "backup" "become" "before" "block"
-"body" "cache" "cancel" "cascade" "change" "checkpoint" "cluster"
-"comment" "compile" "compress" "compute" "connect" "constraint"
-"constraints" "contents" "controlfile" "cross" "currval" "cycle"
-"database" "datafile" "dba" "deterministic" "disable" "dismount"
-"drop" "dump" "each" "else" "else" "elsif" "enable" "events" "except"
-"exceptions" "exclusive" "execute" "exit" "explain" "extent"
-"externally" "false" "file" "flush" "force" "freelist" "freelists"
-"full" "function" "global" "grant" "groups" "identified" "if"
-"immediate" "including" "increment" "index" "initial" "initrans"
-"inner" "instance" "intersect" "join" "layer" "left" "level" "link"
-"lists" "lock" "logfile" "long" "loop" "manage" "manual"
-"maxdatafiles" "maxextents" "maxinistances" "maxlogfiles"
-"maxloghistory" "maxlogmembers" "maxtrans" "maxvalue" "merge"
-"minextents" "minus" "minvalue" "mode" "modify" "mount" "natural"
-"new" "next" "nextval" "noarchivelog" "noaudit" "nocache" "nocompress"
-"nocycle" "nomaxvalue" "nominvalue" "none" "noorder" "noresetlogs"
-"normal" "nosort" "nowait" "off" "offline" "old" "online" "only"
-"optimal" "others" "out" "outer" "over" "own" "package" "parallel"
-"parallel_enable" "pctfree" "pctincrease" "pctused" "plan" "pragma"
-"preserve" "prior" "private" "profile" "quota" "raise" "raw" "read"
-"recover" "referencing" "rename" "replace" "resetlogs" "resource"
-"restrict_references" "restricted" "return" "returning" "reuse"
-"revoke" "right" "rnds" "rnps" "role" "roles" "row" "rowlabel"
-"rownum" "rows" "savepoint" "scn" "segment" "sequence" "session"
-"share" "shared" "size" "snapshot" "sort" "statement_id" "statistics"
-"stop" "storage" "subtype" "successful" "switch" "synonym" "sysdate"
-"system" "tables" "tablespace" "temporary" "then" "thread" "tracing"
-"transaction" "trigger" "triggers" "true" "truncate" "type" "uid"
-"under" "unlimited" "until" "use" "using" "validate" "when" "while"
-"wnds" "wnps" "write"
-
-) t) "\\b")))
- (oracle-warning-words (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; PLSQL defined exceptions
-
+ (let ((oracle-functions (sql-keywords-re
+"abs" "acos" "add_months" "ascii" "asciistr" "asin" "atan" "atan2"
+"avg" "bfilename" "bin_to_num" "bitand" "cast" "ceil" "chartorowid"
+"chr" "coalesce" "compose" "concat" "convert" "corr" "cos" "cosh"
+"count" "covar_pop" "covar_samp" "cume_dist" "current_date"
+"current_timestamp" "current_user" "dbtimezone" "decode" "decompose"
+"dense_rank" "depth" "deref" "dump" "empty_clob" "existsnode" "exp"
+"extract" "extractvalue" "first" "first_value" "floor" "following"
+"from_tz" "greatest" "group_id" "grouping_id" "hextoraw" "initcap"
+"instr" "lag" "last" "last_day" "last_value" "lead" "least" "length"
+"ln" "localtimestamp" "lower" "lpad" "ltrim" "make_ref" "max" "min"
+"mod" "months_between" "new_time" "next_day" "nls_charset_decl_len"
+"nls_charset_id" "nls_charset_name" "nls_initcap" "nls_lower"
+"nls_upper" "nlssort" "ntile" "nullif" "numtodsinterval"
+"numtoyminterval" "nvl" "nvl2" "over" "path" "percent_rank"
+"percentile_cont" "percentile_disc" "power" "preceding" "rank"
+"ratio_to_report" "rawtohex" "rawtonhex" "reftohex" "regr_"
+"regr_avgx" "regr_avgy" "regr_count" "regr_intercept" "regr_r2"
+"regr_slope" "regr_sxx" "regr_sxy" "regr_syy" "replace" "round"
+"row_number" "rowidtochar" "rowidtonchar" "rpad" "rtrim"
+"sessiontimezone" "sign" "sin" "sinh" "soundex" "sqrt" "stddev"
+"stddev_pop" "stddev_samp" "substr" "sum" "sys_connect_by_path"
+"sys_context" "sys_dburigen" "sys_extract_utc" "sys_guid" "sys_typeid"
+"sys_xmlagg" "sys_xmlgen" "sysdate" "systimestamp" "tan" "tanh"
+"to_char" "to_clob" "to_date" "to_dsinterval" "to_lob" "to_multi_byte"
+"to_nchar" "to_nclob" "to_number" "to_single_byte" "to_timestamp"
+"to_timestamp_tz" "to_yminterval" "translate" "treat" "trim" "trunc"
+"tz_offset" "uid" "unbounded" "unistr" "updatexml" "upper" "user"
+"userenv" "var_pop" "var_samp" "variance" "vsize" "width_bucket" "xml"
+"xmlagg" "xmlattribute" "xmlcolattval" "xmlconcat" "xmlelement"
+"xmlforest" "xmlsequence" "xmltransform"
+))
+
+ (oracle-keywords (sql-keywords-re
+"abort" "access" "accessed" "account" "activate" "add" "admin"
+"advise" "after" "agent" "aggregate" "all" "allocate" "allow" "alter"
+"always" "analyze" "ancillary" "and" "any" "apply" "archive"
+"archivelog" "array" "as" "asc" "associate" "at" "attribute"
+"attributes" "audit" "authenticated" "authid" "authorization" "auto"
+"autoallocate" "automatic" "availability" "backup" "before" "begin"
+"behalf" "between" "binding" "bitmap" "block" "blocksize" "body"
+"both" "buffer_pool" "build" "by" "cache" "call" "cancel"
+"cascade" "case" "category" "certificate" "chained" "change" "check"
+"checkpoint" "child" "chunk" "class" "clear" "clone" "close" "cluster"
+"column" "column_value" "columns" "comment" "commit" "committed"
+"compatibility" "compile" "complete" "composite_limit" "compress"
+"compute" "connect" "connect_time" "consider" "consistent"
+"constraint" "constraints" "constructor" "contents" "context"
+"continue" "controlfile" "corruption" "cost" "cpu_per_call"
+"cpu_per_session" "create" "cross" "cube" "current" "currval" "cycle"
+"dangling" "data" "database" "datafile" "datafiles" "day" "ddl"
+"deallocate" "debug" "default" "deferrable" "deferred" "definer"
+"delay" "delete" "demand" "desc" "determines" "deterministic"
+"dictionary" "dimension" "directory" "disable" "disassociate"
+"disconnect" "distinct" "distinguished" "distributed" "dml" "drop"
+"each" "element" "else" "enable" "end" "equals_path" "escape"
+"estimate" "except" "exceptions" "exchange" "excluding" "exists"
+"expire" "explain" "extent" "external" "externally"
+"failed_login_attempts" "fast" "file" "final" "finish" "flush" "for"
+"force" "foreign" "freelist" "freelists" "freepools" "fresh" "from"
+"full" "function" "functions" "generated" "global" "global_name"
+"globally" "grant" "group" "grouping" "groups" "guard" "hash"
+"hashkeys" "having" "heap" "hierarchy" "id" "identified" "identifier"
+"idle_time" "immediate" "in" "including" "increment" "index" "indexed"
+"indexes" "indextype" "indextypes" "indicator" "initial" "initialized"
+"initially" "initrans" "inner" "insert" "instance" "instantiable"
+"instead" "intersect" "into" "invalidate" "is" "isolation" "java"
+"join" "keep" "key" "kill" "language" "left" "less" "level"
+"levels" "library" "like" "like2" "like4" "likec" "limit" "link"
+"list" "lob" "local" "location" "locator" "lock" "log" "logfile"
+"logging" "logical" "logical_reads_per_call"
+"logical_reads_per_session" "managed" "management" "manual" "map"
+"mapping" "master" "matched" "materialized" "maxdatafiles"
+"maxextents" "maximize" "maxinstances" "maxlogfiles" "maxloghistory"
+"maxlogmembers" "maxsize" "maxtrans" "maxvalue" "member" "memory"
+"merge" "migrate" "minextents" "minimize" "minimum" "minus" "minvalue"
+"mode" "modify" "monitoring" "month" "mount" "move" "movement" "name"
+"named" "natural" "nested" "never" "new" "next" "nextval" "no"
+"noarchivelog" "noaudit" "nocache" "nocompress" "nocopy" "nocycle"
+"nodelay" "noforce" "nologging" "nomapping" "nomaxvalue" "nominimize"
+"nominvalue" "nomonitoring" "none" "noorder" "noparallel" "norely"
+"noresetlogs" "noreverse" "normal" "norowdependencies" "nosort"
+"noswitch" "not" "nothing" "notimeout" "novalidate" "nowait" "null"
+"nulls" "object" "of" "off" "offline" "oidindex" "old" "on" "online"
+"only" "open" "operator" "optimal" "option" "or" "order"
+"organization" "out" "outer" "outline" "overflow" "overriding"
+"package" "packages" "parallel" "parallel_enable" "parameters"
+"parent" "partition" "partitions" "password" "password_grace_time"
+"password_life_time" "password_lock_time" "password_reuse_max"
+"password_reuse_time" "password_verify_function" "pctfree"
+"pctincrease" "pctthreshold" "pctused" "pctversion" "percent"
+"performance" "permanent" "pfile" "physical" "pipelined" "plan"
+"post_transaction" "pragma" "prebuilt" "preserve" "primary" "private"
+"private_sga" "privileges" "procedure" "profile" "protection" "public"
+"purge" "query" "quiesce" "quota" "range" "read" "reads" "rebuild"
+"records_per_block" "recover" "recovery" "recycle" "reduced" "ref"
+"references" "referencing" "refresh" "register" "reject" "relational"
+"rely" "rename" "reset" "resetlogs" "resize" "resolve" "resolver"
+"resource" "restrict" "restrict_references" "restricted" "result"
+"resumable" "resume" "retention" "return" "returning" "reuse"
+"reverse" "revoke" "rewrite" "right" "rnds" "rnps" "role" "roles"
+"rollback" "rollup" "row" "rowdependencies" "rownum" "rows" "sample"
+"savepoint" "scan" "schema" "scn" "scope" "segment" "select"
+"selectivity" "self" "sequence" "serializable" "session"
+"sessions_per_user" "set" "sets" "settings" "shared" "shared_pool"
+"shrink" "shutdown" "siblings" "sid" "single" "size" "skip" "some"
+"sort" "source" "space" "specification" "spfile" "split" "standby"
+"start" "statement_id" "static" "statistics" "stop" "storage" "store"
+"structure" "subpartition" "subpartitions" "substitutable"
+"successful" "supplemental" "suspend" "switch" "switchover" "synonym"
+"sys" "system" "table" "tables" "tablespace" "tempfile" "template"
+"temporary" "test" "than" "then" "thread" "through" "time_zone"
+"timeout" "to" "trace" "transaction" "trigger" "triggers" "truncate"
+"trust" "type" "types" "unarchived" "under" "under_path" "undo"
+"uniform" "union" "unique" "unlimited" "unlock" "unquiesce"
+"unrecoverable" "until" "unusable" "unused" "update" "upgrade" "usage"
+"use" "using" "validate" "validation" "value" "values" "variable"
+"varray" "version" "view" "wait" "when" "whenever" "where" "with"
+"without" "wnds" "wnps" "work" "write" "xmldata" "xmlschema" "xmltype"
+))
+
+ (oracle-types (sql-keywords-re
+"bfile" "blob" "byte" "char" "character" "clob" "date" "dec" "decimal"
+"double" "float" "int" "integer" "interval" "long" "national" "nchar"
+"nclob" "number" "numeric" "nvarchar2" "precision" "raw" "real"
+"rowid" "second" "smallint" "time" "timestamp" "urowid" "varchar"
+"varchar2" "varying" "year" "zone"
+))
+
+ (plsql-functions (sql-keywords-re
+"%bulk_rowcount" "%found" "%isopen" "%notfound" "%rowcount" "%rowtype"
+"%type" "extend" "prior"
+))
+
+ (plsql-keywords (sql-keywords-re
+"autonomous_transaction" "bulk" "char_base" "collect" "constant"
+"cursor" "declare" "do" "elsif" "exception_init" "execute" "exit"
+"extends" "false" "fetch" "forall" "goto" "hour" "if" "interface"
+"loop" "minute" "number_base" "ocirowid" "opaque" "others" "rowtype"
+"separate" "serially_reusable" "sql" "sqlcode" "sqlerrm" "subtype"
+"the" "timezone_abbr" "timezone_hour" "timezone_minute"
+"timezone_region" "true" "varrying" "while"
+))
+
+ (plsql-type (sql-keywords-re
+"binary_integer" "boolean" "naturaln" "pls_integer" "positive"
+"positiven" "record" "signtype" "string"
+))
+
+ (plsql-warning (sql-keywords-re
"access_into_null" "case_not_found" "collection_is_null"
"cursor_already_open" "dup_val_on_index" "invalid_cursor"
"invalid_number" "login_denied" "no_data_found" "not_logged_on"
@@ -997,15 +1159,11 @@ add functions and PL/SQL keywords.")
"subscript_beyond_count" "subscript_outside_limit" "sys_invalid_rowid"
"timeout_on_resource" "too_many_rows" "value_error" "zero_divide"
"exception" "notfound"
+))
-) t) "\\b")))
-
- (oracle-sqlplus-commands
- (eval-when-compile
- (concat "^\\(\\("
- (regexp-opt '(
-;; SQL*Plus commands
-
+ (sqlplus-commands
+ (eval-when-compile (concat "^\\(\\("
+ (regexp-opt '(
"@" "@@" "accept" "append" "archive" "attribute" "break"
"btitle" "change" "clear" "column" "connect" "copy" "define"
"del" "describe" "disconnect" "edit" "execute" "exit" "get" "help"
@@ -1040,73 +1198,16 @@ add functions and PL/SQL keywords.")
"timi\\(ng\\)?\\|trim\\(out\\)?\\|trims\\(pool\\)?\\|"
"und\\(erline\\)?\\|ver\\(ify\\)?\\|wra\\(p\\)?\\)\\)\\)"
"\\b.*$"
- )))
+ ))))
- (oracle-types
- (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; Oracle Keywords that look like types
-;; Oracle Reserved Words that look like types
-
-"bfile" "binary_integer" "blob" "boolean" "byte" "char" "character"
-"clob" "date" "day" "dec" "decimal" "double" "float" "int" "integer"
-"interval" "local" "long" "month" "natural" "naturaln" "nchar" "nclob"
-"number" "numeric" "nvarchar2" "pls_integer" "positive" "positiven"
-"precision" "raw" "real" "rowid" "second" "signtype" "smallint"
-"string" "time" "timestamp" "urowid" "varchar" "varchar2" "year"
-"zone"
-
-) t) "\\b")))
- (oracle-builtin-functions (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; Misc Oracle builtin functions
-
-"abs" "acos" "add_months" "ascii" "asciistr" "asin" "atan" "atan2"
-"avg" "bfilename" "bin_to_num" "bitand" "case" "cast" "ceil"
-"chartorowid" "chr" "coalesce" "compose" "concat" "convert" "corr"
-"cos" "cosh" "count" "covar_pop" "covar_samp" "cume_dist"
-"current_date" "current_timestamp" "current_user" "dbtimezone"
-"decode" "decompose" "dense_rank" "depth" "deref" "dump" "empty_blob"
-"empty_clob" "existsnode" "exp" "extract" "extractvalue" "first"
-"first_value" "floor" "from_tz" "greatest" "group_id" "grouping"
-"grouping_id" "hextoraw" "initcap" "instr" "lag" "last" "last_day"
-"last_value" "lead" "least" "length" "ln" "localtimestamp" "log"
-"lower" "lpad" "ltrim" "make_ref" "max" "min" "mod" "months_between"
-"nchr" "new_time" "next_day" "nls_charset_decl_len" "nls_charset_id"
-"nls_charset_name" "nls_initcap" "nls_lower" "nlssort" "nls_upper"
-"ntile" "nullif" "numtodsinterval" "numtoyminterval" "nvl" "nvl2"
-"path" "percent_rank" "percentile_cont" "percentile_disc" "power"
-"rank" "ratio_to_report" "rawtohex" "rawtonhex" "ref" "reftohex"
-"regr_slope" "regr_intercept" "regr_count" "regr_r2" "regr_avgx"
-"regr_avgy" "regr_sxx" "regr_syy" "regr_sxy" "round"
-"row_number" "rowidtochar" "rowidtonchar" "rpad" "rtrim"
-"sessiontimezone" "sign" "sin" "sinh" "soundex" "sqrt" "stddev"
-"stddev_pop" "stddev_samp" "substr" "sum" "sys_connect_by_path"
-"sys_context" "sys_dburigen" "sys_extract_utc" "sys_guid" "sys_typeid"
-"sys_xmlagg" "sys_xmlgen" "sysdate" "systimestamp" "tan" "tanh"
-"to_char" "to_clob" "to_date" "to_dsinterval" "to_lob" "to_multi_byte"
-"to_nchar" "to_nclob" "to_number" "to_single_byte" "to_timestamp"
-"to_timestamp_tz" "to_yminterval" "translate" "treat" "trim" "trunc"
-"tz_offset" "uid" "unistr" "updatexml" "upper" "user" "userenv"
-"value" "var_pop" "var_samp" "variance" "vsize" "width_bucket"
-"xmlagg" "xmlcolattval" "xmlconcat" "xmlelement" "xmlforest"
-"xmlsequence" "xmltransform"
-
-) t) "\\b"))))
- (list (cons oracle-sqlplus-commands 'font-lock-doc-face)
- (cons oracle-keywords 'font-lock-keyword-face)
- (cons oracle-warning-words 'font-lock-warning-face)
- ;; XEmacs doesn't have font-lock-builtin-face
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- (cons oracle-builtin-functions 'font-lock-preprocessor-face)
- ;; GNU Emacs 19 doesn't have it either
- (if (string-match "GNU Emacs 19" emacs-version)
- (cons oracle-builtin-functions 'font-lock-keyword-face)
- ;; Emacs
- (cons oracle-builtin-functions 'font-lock-builtin-face)))
- (cons oracle-types 'font-lock-type-face)))
+ `((,sqlplus-commands . font-lock-doc-face)
+ (,oracle-functions . font-lock-builtin-face)
+ (,oracle-keywords . font-lock-keyword-face)
+ (,oracle-types . font-lock-type-face)
+ (,plsql-functions . font-lock-builtin-face)
+ (,plsql-keywords . font-lock-keyword-face)
+ (,plsql-type . font-lock-type-face)
+ (,plsql-warning . font-lock-warning-face)))
"Oracle SQL keywords used by font-lock.
@@ -1117,42 +1218,84 @@ you define your own sql-mode-oracle-font-lock-keywords. You may want
to add functions and PL/SQL keywords.")
(defvar sql-mode-postgres-font-lock-keywords
- (let ((postgres-reserved-words (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-"language"
-) t) "\\b")))
- (postgres-types (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
-"bool" "box" "circle" "char" "char2" "char4" "char8" "char16" "date"
-"float4" "float8" "int2" "int4" "int8" "line" "lseg" "money" "path"
-"point" "polygon" "serial" "text" "time" "timespan" "timestamp" "varchar"
-
-) t)"\\b")))
- (postgres-builtin-functions (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; Misc Postgres builtin functions
-
-"abstime" "age" "area" "box" "center" "date_part" "date_trunc"
-"datetime" "dexp" "diameter" "dpow" "float" "float4" "height"
-"initcap" "integer" "isclosed" "isfinite" "isoldpath" "isopen"
-"length" "lower" "lpad" "ltrim" "pclose" "point" "points" "popen"
-"position" "radius" "reltime" "revertpoly" "rpad" "rtrim" "substr"
-"substring" "text" "timespan" "translate" "trim" "upgradepath"
-"upgradepoly" "upper" "varchar" "width"
-
-) t) "\\b"))))
- (append sql-mode-ansi-font-lock-keywords
- (list (cons postgres-reserved-words 'font-lock-keyword-face)
- ;; XEmacs doesn't have 'font-lock-builtin-face
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- (cons postgres-builtin-functions 'font-lock-preprocessor-face)
- ;; Emacs
- (cons postgres-builtin-functions 'font-lock-builtin-face))
- (cons postgres-types 'font-lock-type-face))))
+ (let ((pg-funcs (sql-keywords-re
+"abbrev" "abs" "acos" "age" "area" "ascii" "asin" "atab2" "atan"
+"atan2" "avg" "bit_length" "both" "broadcast" "btrim" "cbrt" "ceil"
+"center" "char_length" "chr" "coalesce" "col_description" "convert"
+"cos" "cot" "count" "current_database" "current_date" "current_schema"
+"current_schemas" "current_setting" "current_time" "current_timestamp"
+"current_user" "currval" "date_part" "date_trunc" "decode" "degrees"
+"diameter" "encode" "exp" "extract" "floor" "get_bit" "get_byte"
+"has_database_privilege" "has_function_privilege"
+"has_language_privilege" "has_schema_privilege" "has_table_privilege"
+"height" "host" "initcap" "isclosed" "isfinite" "isopen" "leading"
+"length" "ln" "localtime" "localtimestamp" "log" "lower" "lpad"
+"ltrim" "masklen" "max" "min" "mod" "netmask" "network" "nextval"
+"now" "npoints" "nullif" "obj_description" "octet_length" "overlay"
+"pclose" "pg_client_encoding" "pg_function_is_visible"
+"pg_get_constraintdef" "pg_get_indexdef" "pg_get_ruledef"
+"pg_get_userbyid" "pg_get_viewdef" "pg_opclass_is_visible"
+"pg_operator_is_visible" "pg_table_is_visible" "pg_type_is_visible"
+"pi" "popen" "position" "pow" "quote_ident" "quote_literal" "radians"
+"radius" "random" "repeat" "replace" "round" "rpad" "rtrim"
+"session_user" "set_bit" "set_byte" "set_config" "set_masklen"
+"setval" "sign" "sin" "split_part" "sqrt" "stddev" "strpos" "substr"
+"substring" "sum" "tan" "timeofday" "to_ascii" "to_char" "to_date"
+"to_hex" "to_number" "to_timestamp" "trailing" "translate" "trim"
+"trunc" "upper" "variance" "version" "width"
+))
+
+ (pg-reserved (sql-keywords-re
+"abort" "access" "add" "after" "aggregate" "alignment" "all" "alter"
+"analyze" "and" "any" "as" "asc" "assignment" "authorization"
+"backward" "basetype" "before" "begin" "between" "binary" "by" "cache"
+"called" "cascade" "case" "cast" "characteristics" "check"
+"checkpoint" "class" "close" "cluster" "column" "comment" "commit"
+"committed" "commutator" "constraint" "constraints" "conversion"
+"copy" "create" "createdb" "createuser" "cursor" "cycle" "database"
+"deallocate" "declare" "default" "deferrable" "deferred" "definer"
+"delete" "delimiter" "desc" "distinct" "do" "domain" "drop" "each"
+"element" "else" "encoding" "encrypted" "end" "escape" "except"
+"exclusive" "execute" "exists" "explain" "extended" "external" "false"
+"fetch" "finalfunc" "for" "force" "foreign" "forward" "freeze" "from"
+"full" "function" "grant" "group" "gtcmp" "handler" "hashes" "having"
+"immediate" "immutable" "implicit" "in" "increment" "index" "inherits"
+"initcond" "initially" "input" "insensitive" "insert" "instead"
+"internallength" "intersect" "into" "invoker" "is" "isnull"
+"isolation" "join" "key" "language" "leftarg" "level" "like" "limit"
+"listen" "load" "local" "location" "lock" "ltcmp" "main" "match"
+"maxvalue" "merges" "minvalue" "mode" "move" "natural" "negator"
+"next" "nocreatedb" "nocreateuser" "none" "not" "nothing" "notify"
+"notnull" "null" "of" "offset" "oids" "on" "only" "operator" "or"
+"order" "output" "owner" "partial" "passedbyvalue" "password" "plain"
+"prepare" "primary" "prior" "privileges" "procedural" "procedure"
+"public" "read" "recheck" "references" "reindex" "relative" "rename"
+"reset" "restrict" "returns" "revoke" "rightarg" "rollback" "row"
+"rule" "schema" "scroll" "security" "select" "sequence" "serializable"
+"session" "set" "sfunc" "share" "show" "similar" "some" "sort1"
+"sort2" "stable" "start" "statement" "statistics" "storage" "strict"
+"stype" "sysid" "table" "temp" "template" "temporary" "then" "to"
+"transaction" "trigger" "true" "truncate" "trusted" "type"
+"unencrypted" "union" "unique" "unknown" "unlisten" "until" "update"
+"usage" "user" "using" "vacuum" "valid" "validator" "values"
+"variable" "verbose" "view" "volatile" "when" "where" "with" "without"
+"work"
+))
+
+ (pg-types (sql-keywords-re
+"anyarray" "bigint" "bigserial" "bit" "boolean" "box" "bytea" "char"
+"character" "cidr" "circle" "cstring" "date" "decimal" "double"
+"float4" "float8" "inet" "int2" "int4" "int8" "integer" "internal"
+"interval" "language_handler" "line" "lseg" "macaddr" "money"
+"numeric" "oid" "opaque" "path" "point" "polygon" "precision" "real"
+"record" "regclass" "regoper" "regoperator" "regproc" "regprocedure"
+"regtype" "serial" "serial4" "serial8" "smallint" "text" "time"
+"timestamp" "varchar" "varying" "void" "zone"
+)))
+
+ `((,pg-funcs . font-lock-builtin-face)
+ (,pg-reserved . font-lock-keyword-face)
+ (,pg-types . font-lock-type-face)))
"Postgres SQL keywords used by font-lock.
@@ -1162,10 +1305,7 @@ function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-postgres-font-lock-keywords.")
(defvar sql-mode-linter-font-lock-keywords
- (let ((linter-keywords (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
+ (let ((linter-keywords (sql-keywords-re
"autocommit" "autoinc" "autorowid" "cancel" "cascade" "channel"
"committed" "count" "countblob" "cross" "current" "data" "database"
"datafile" "datafiles" "datesplit" "dba" "dbname" "default" "deferred"
@@ -1190,12 +1330,9 @@ you define your own sql-mode-postgres-font-lock-keywords.")
"trigger_info_size" "true" "trunc" "uncommitted" "unicode" "unknown"
"unlimited" "unlisted" "user" "utf8" "value" "varying" "volumes"
"wait" "windows_code" "workspace" "write" "xml"
+))
-) t) "\\b")))
- (linter-reserved-words (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
+ (linter-reserved (sql-keywords-re
"access" "action" "add" "address" "after" "all" "alter" "always" "and"
"any" "append" "as" "asc" "ascic" "async" "at_begin" "at_end" "audit"
"aud_obj_name_len" "backup" "base" "before" "between" "blobfile"
@@ -1213,22 +1350,16 @@ you define your own sql-mode-postgres-font-lock-keywords.")
"start" "stop" "sync" "synchronize" "synonym" "sysdate" "table" "then"
"to" "union" "unique" "unlock" "until" "update" "using" "values"
"view" "when" "where" "with" "without"
+))
-) t) "\\b")))
- (linter-types (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
+ (linter-types (sql-keywords-re
"bigint" "bitmap" "blob" "boolean" "char" "character" "date"
"datetime" "dec" "decimal" "double" "float" "int" "integer" "nchar"
"number" "numeric" "real" "smallint" "varbyte" "varchar" "byte"
"cursor" "long"
+))
-) t) "\\b")))
- (linter-builtin-functions (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
+ (linter-functions (sql-keywords-re
"abs" "acos" "asin" "atan" "atan2" "avg" "ceil" "cos" "cosh" "divtime"
"exp" "floor" "getbits" "getblob" "getbyte" "getlong" "getraw"
"getstr" "gettext" "getword" "hextoraw" "lenblob" "length" "log"
@@ -1239,20 +1370,12 @@ you define your own sql-mode-postgres-font-lock-keywords.")
"to_gmtime" "to_localtime" "to_number" "trim" "upper" "decode"
"substr" "substring" "chr" "dayname" "days" "greatest" "hex" "initcap"
"instr" "least" "multime" "replace" "width"
+)))
-) t) "\\b"))))
- (append sql-mode-ansi-font-lock-keywords
- (list (cons linter-keywords 'font-lock-keywords-face)
- (cons linter-reserved-words 'font-lock-keyword-face)
- ;; XEmacs doesn't have font-lock-builtin-face
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- (cons linter-builtin-functions 'font-lock-preprocessor-face)
- ;; GNU Emacs 19 doesn't have it either
- (if (string-match "GNU Emacs 19" emacs-version)
- (cons linter-builtin-functions 'font-lock-keywords-face)
- ;; Emacs
- (cons linter-builtin-functions 'font-lock-builtin-face)))
- (cons linter-types 'font-lock-type-face))))
+ `((,linter-keywords . font-lock-keyword-face)
+ (,linter-reserved . font-lock-keyword-face)
+ (,linter-functions . font-lock-builtin-face)
+ (,linter-types . font-lock-type-face)))
"Linter SQL keywords used by font-lock.
@@ -1261,21 +1384,18 @@ regular expressions are created during compilation by calling the
function `regexp-opt'.")
(defvar sql-mode-ms-font-lock-keywords
- (let ((ms-reserved-words (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-
+ (let ((ms-reserved (sql-keywords-re
"absolute" "add" "all" "alter" "and" "any" "as" "asc" "authorization"
"avg" "backup" "begin" "between" "break" "browse" "bulk" "by"
"cascade" "case" "check" "checkpoint" "close" "clustered" "coalesce"
"column" "commit" "committed" "compute" "confirm" "constraint"
"contains" "containstable" "continue" "controlrow" "convert" "count"
"create" "cross" "current" "current_date" "current_time"
-"current_timestamp" "current_user" "database" "deallocate"
-"declare" "default" "delete" "deny" "desc" "disk" "distinct"
-"distributed" "double" "drop" "dummy" "dump" "else" "end" "errlvl"
-"errorexit" "escape" "except" "exec" "execute" "exists" "exit" "fetch"
-"file" "fillfactor" "first" "floppy" "for" "foreign" "freetext"
+"current_timestamp" "current_user" "database" "deallocate" "declare"
+"default" "delete" "deny" "desc" "disk" "distinct" "distributed"
+"double" "drop" "dummy" "dump" "else" "end" "errlvl" "errorexit"
+"escape" "except" "exec" "execute" "exists" "exit" "fetch" "file"
+"fillfactor" "first" "floppy" "for" "foreign" "freetext"
"freetexttable" "from" "full" "goto" "grant" "group" "having"
"holdlock" "identity" "identity_insert" "identitycol" "if" "in"
"index" "inner" "insert" "intersect" "into" "is" "isolation" "join"
@@ -1295,29 +1415,21 @@ function `regexp-opt'.")
"textsize" "then" "to" "top" "tran" "transaction" "trigger" "truncate"
"tsequal" "uncommitted" "union" "unique" "update" "updatetext"
"updlock" "use" "user" "values" "view" "waitfor" "when" "where"
-"while" "with" "work" "writetext"
-"collate" "function" "openxml" "returns"
-
-) t) "\\b")))
- (ms-types (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
+"while" "with" "work" "writetext" "collate" "function" "openxml"
+"returns"
+))
+ (ms-types (sql-keywords-re
"binary" "bit" "char" "character" "cursor" "datetime" "dec" "decimal"
"double" "float" "image" "int" "integer" "money" "national" "nchar"
"ntext" "numeric" "numeric" "nvarchar" "precision" "real"
"smalldatetime" "smallint" "smallmoney" "text" "timestamp" "tinyint"
"uniqueidentifier" "varbinary" "varchar" "varying"
-
-) t) "\\b")))
+))
(ms-vars "\\b@[a-zA-Z0-9_]*\\b")
- (ms-builtin-functions (eval-when-compile
- (concat "\\b"
- (regexp-opt '(
-;; Misc MS builtin functions
-
+ (ms-functions (sql-keywords-re
"@@connections" "@@cpu_busy" "@@cursor_rows" "@@datefirst" "@@dbts"
"@@error" "@@fetch_status" "@@identity" "@@idle" "@@io_busy"
"@@langid" "@@language" "@@lock_timeout" "@@max_connections"
@@ -1346,14 +1458,12 @@ function `regexp-opt'.")
"suser_id" "suser_name" "suser_sid" "suser_sname" "system_user" "tan"
"textptr" "textvalid" "typeproperty" "unicode" "upper" "user"
"user_id" "user_name" "var" "varp" "year"
+))
-) t) "\\b")))
-
- (ms-config-commands
+ (ms-commands
(eval-when-compile
(concat "^\\(\\(set\\s-+\\("
(regexp-opt '(
-
"datefirst" "dateformat" "deadlock_priority" "lock_timeout"
"concat_null_yields_null" "cursor_close_on_commit"
"disable_def_cnst_chk" "fips_flagger" "identity_insert" "language"
@@ -1364,19 +1474,14 @@ function `regexp-opt'.")
"ansi_warnings" "forceplan" "showplan_all" "showplan_text"
"statistics" "implicit_transactions" "remote_proc_transactions"
"transaction" "xact_abort"
-
) t)
"\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$"))))
- (list (cons ms-config-commands 'font-lock-doc-face)
- (cons ms-reserved-words 'font-lock-keyword-face)
- ;; XEmacs doesn't have 'font-lock-builtin-face
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- (cons ms-builtin-functions 'font-lock-preprocessor-face)
- ;; Emacs
- (cons ms-builtin-functions 'font-lock-builtin-face))
- (cons ms-vars 'font-lock-variable-name-face)
- (cons ms-types 'font-lock-type-face)))
+ `((,ms-commands . font-lock-doc-face)
+ (,ms-reserved . font-lock-keyword-face)
+ (,ms-functions . font-lock-builtin-face)
+ (,ms-vars . font-lock-variable-name-face)
+ (,ms-types . font-lock-type-face)))
"Microsoft SQLServer SQL keywords used by font-lock.
@@ -1385,7 +1490,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-ms-font-lock-keywords.")
-(defvar sql-mode-sybase-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-sybase-font-lock-keywords nil
"Sybase SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1393,7 +1498,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-sybase-font-lock-keywords.")
-(defvar sql-mode-informix-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-informix-font-lock-keywords nil
"Informix SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1401,7 +1506,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-informix-font-lock-keywords.")
-(defvar sql-mode-interbase-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-interbase-font-lock-keywords nil
"Interbase SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1409,7 +1514,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-interbase-font-lock-keywords.")
-(defvar sql-mode-ingres-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-ingres-font-lock-keywords nil
"Ingres SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1417,7 +1522,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-interbase-font-lock-keywords.")
-(defvar sql-mode-solid-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-solid-font-lock-keywords nil
"Solid SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1425,7 +1530,76 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-solid-font-lock-keywords.")
-(defvar sql-mode-mysql-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-mysql-font-lock-keywords
+ (let ((mysql-funcs (sql-keywords-re
+"ascii" "avg" "bdmpolyfromtext" "bdmpolyfromwkb" "bdpolyfromtext"
+"bdpolyfromwkb" "benchmark" "bin" "bit_and" "bit_length" "bit_or"
+"bit_xor" "both" "cast" "char_length" "character_length" "coalesce"
+"concat" "concat_ws" "connection_id" "conv" "convert" "count"
+"curdate" "current_date" "current_time" "current_timestamp" "curtime"
+"elt" "encrypt" "export_set" "field" "find_in_set" "found_rows" "from"
+"geomcollfromtext" "geomcollfromwkb" "geometrycollectionfromtext"
+"geometrycollectionfromwkb" "geometryfromtext" "geometryfromwkb"
+"geomfromtext" "geomfromwkb" "get_lock" "group_concat" "hex" "ifnull"
+"instr" "interval" "isnull" "last_insert_id" "lcase" "leading"
+"length" "linefromtext" "linefromwkb" "linestringfromtext"
+"linestringfromwkb" "load_file" "locate" "lower" "lpad" "ltrim"
+"make_set" "master_pos_wait" "max" "mid" "min" "mlinefromtext"
+"mlinefromwkb" "mpointfromtext" "mpointfromwkb" "mpolyfromtext"
+"mpolyfromwkb" "multilinestringfromtext" "multilinestringfromwkb"
+"multipointfromtext" "multipointfromwkb" "multipolygonfromtext"
+"multipolygonfromwkb" "now" "nullif" "oct" "octet_length" "ord"
+"pointfromtext" "pointfromwkb" "polyfromtext" "polyfromwkb"
+"polygonfromtext" "polygonfromwkb" "position" "quote" "rand"
+"release_lock" "repeat" "replace" "reverse" "rpad" "rtrim" "soundex"
+"space" "std" "stddev" "substring" "substring_index" "sum" "sysdate"
+"trailing" "trim" "ucase" "unix_timestamp" "upper" "user" "variance"
+))
+
+ (mysql-keywords (sql-keywords-re
+"action" "add" "after" "against" "all" "alter" "and" "as" "asc"
+"auto_increment" "avg_row_length" "bdb" "between" "by" "cascade"
+"case" "change" "character" "check" "checksum" "close" "collate"
+"collation" "column" "columns" "comment" "committed" "concurrent"
+"constraint" "create" "cross" "data" "database" "default"
+"delay_key_write" "delayed" "delete" "desc" "directory" "disable"
+"distinct" "distinctrow" "do" "drop" "dumpfile" "duplicate" "else"
+"enable" "enclosed" "end" "escaped" "exists" "fields" "first" "for"
+"force" "foreign" "from" "full" "fulltext" "global" "group" "handler"
+"having" "heap" "high_priority" "if" "ignore" "in" "index" "infile"
+"inner" "insert" "insert_method" "into" "is" "isam" "isolation" "join"
+"key" "keys" "last" "left" "level" "like" "limit" "lines" "load"
+"local" "lock" "low_priority" "match" "max_rows" "merge" "min_rows"
+"mode" "modify" "mrg_myisam" "myisam" "natural" "next" "no" "not"
+"null" "offset" "oj" "on" "open" "optionally" "or" "order" "outer"
+"outfile" "pack_keys" "partial" "password" "prev" "primary"
+"procedure" "quick" "raid0" "raid_type" "read" "references" "rename"
+"repeatable" "restrict" "right" "rollback" "rollup" "row_format"
+"savepoint" "select" "separator" "serializable" "session" "set"
+"share" "show" "sql_big_result" "sql_buffer_result" "sql_cache"
+"sql_calc_found_rows" "sql_no_cache" "sql_small_result" "starting"
+"straight_join" "striped" "table" "tables" "temporary" "terminated"
+"then" "to" "transaction" "truncate" "type" "uncommitted" "union"
+"unique" "unlock" "update" "use" "using" "values" "when" "where"
+"with" "write" "xor"
+))
+
+ (mysql-types (sql-keywords-re
+"bigint" "binary" "bit" "blob" "bool" "boolean" "char" "curve" "date"
+"datetime" "dec" "decimal" "double" "enum" "fixed" "float" "geometry"
+"geometrycollection" "int" "integer" "line" "linearring" "linestring"
+"longblob" "longtext" "mediumblob" "mediumint" "mediumtext"
+"multicurve" "multilinestring" "multipoint" "multipolygon"
+"multisurface" "national" "numeric" "point" "polygon" "precision"
+"real" "smallint" "surface" "text" "time" "timestamp" "tinyblob"
+"tinyint" "tinytext" "unsigned" "varchar" "year" "year2" "year4"
+"zerofill"
+)))
+
+ `((,mysql-funcs . font-lock-builtin-face)
+ (,mysql-keywords . font-lock-keyword-face)
+ (,mysql-types . font-lock-type-face)))
+
"MySQL SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1433,7 +1607,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-mysql-font-lock-keywords.")
-(defvar sql-mode-sqlite-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-sqlite-font-lock-keywords nil
"SQLite SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1441,7 +1615,7 @@ regular expressions are created during compilation by calling the
function `regexp-opt'. Therefore, take a look at the source before
you define your own sql-mode-sqlite-font-lock-keywords.")
-(defvar sql-mode-db2-font-lock-keywords sql-mode-ansi-font-lock-keywords
+(defvar sql-mode-db2-font-lock-keywords nil
"DB2 SQL keywords used by font-lock.
This variable is used by `sql-mode' and `sql-interactive-mode'. The
@@ -1463,16 +1637,16 @@ highlighting rules in sql-mode.")
(defun sql-product-feature (feature &optional product)
"Lookup `feature' needed to support the current SQL product.
-See \[sql-product-support] for a list of products and supported features."
- (cadr
- (memq feature
- (assoc (or product sql-product)
- sql-product-support))))
+See \[sql-product-alist] for a list of products and supported features."
+ (plist-get
+ (cdr (assoc (or product sql-product)
+ sql-product-alist))
+ feature))
(defun sql-product-font-lock (keywords-only imenu)
"Sets `font-lock-defaults' and `font-lock-keywords' based on
the product-specific keywords and syntax-alists defined in
-`sql-product-support'."
+`sql-product-alist'."
(let
;; Get the product-specific syntax-alist.
((syntax-alist
@@ -1483,27 +1657,69 @@ the product-specific keywords and syntax-alists defined in
;; Get the product-specific keywords.
(setq sql-mode-font-lock-keywords
(append
- (eval (sql-product-feature :font-lock))
+ (unless (eq sql-product 'ansi)
+ (eval (sql-product-feature :font-lock)))
+ ;; Always highlight ANSI keywords
+ (eval (sql-product-feature :font-lock 'ansi))
+ ;; Fontify object names in CREATE, DROP and ALTER DDL
+ ;; statements
(list sql-mode-font-lock-object-name)))
- ;; Setup font-lock. (What is the minimum we should have to do
- ;; here?)
- (setq font-lock-set-defaults nil
- font-lock-keywords sql-mode-font-lock-keywords
- font-lock-defaults (list 'sql-mode-font-lock-keywords
+ ;; Setup font-lock. Force re-parsing of `font-lock-defaults'.
+ (set (make-local-variable 'font-lock-set-defaults) nil)
+ (setq font-lock-defaults (list 'sql-mode-font-lock-keywords
keywords-only t syntax-alist))
+ ;; Force font lock to reinitialize if it is already on
+ ;; Otherwise, we can wait until it can be started.
+ (when (and (fboundp 'font-lock-mode)
+ font-lock-mode)
+ (font-lock-mode-internal nil)
+ (font-lock-mode-internal t))
+
+ (add-hook 'font-lock-mode-hook
+ (lambda ()
+ ;; Provide defaults for new font-lock faces.
+ (defvar font-lock-builtin-face
+ (if (boundp 'font-lock-preprocessor-face)
+ font-lock-preprocessor-face
+ font-lock-keyword-face))
+ (defvar font-lock-doc-face font-lock-string-face))
+ nil t)
+
;; Setup imenu; it needs the same syntax-alist.
(when imenu
(setq imenu-syntax-alist syntax-alist))))
;;;###autoload
-(defun sql-add-product-keywords (product keywords)
- "Append a `font-lock-keywords' entry to the existing entries defined
- for the specified `product'."
-
- (let ((font-lock (sql-product-feature :font-lock product)))
- (set font-lock (append (eval font-lock) (list keywords)))))
+(defun sql-add-product-keywords (product keywords &optional append)
+ "Add highlighting KEYWORDS for SQL PRODUCT.
+
+PRODUCT should be a symbol, the name of a sql product, such as
+`oracle'. KEYWORDS should be a list; see the variable
+`font-lock-keywords'. By default they are added at the beginning
+of the current highlighting list. If optional argument APPEND is
+`set', they are used to replace the current highlighting list.
+If APPEND is any other non-nil value, they are added at the end
+of the current highlighting list.
+
+For example:
+
+ (sql-add-product-keywords 'ms
+ '((\"\\\\b\\\\w+_t\\\\b\" . font-lock-type-face)))
+
+adds a fontification pattern to fontify identifiers ending in
+`_t' as data types."
+
+ (let ((font-lock (sql-product-feature :font-lock product))
+ old)
+ (setq old (eval font-lock))
+ (set font-lock
+ (if (eq append 'set)
+ keywords
+ (if append
+ (append old keywords)
+ (append keywords old))))))
@@ -1517,10 +1733,6 @@ selected."
;; Setup font-lock
(sql-product-font-lock nil t)
- ;; Force fontification, if its enabled.
- (if font-lock-mode
- (font-lock-fontify-buffer))
-
;; Set the mode name to include the product.
(setq mode-name (concat "SQL[" (prin1-to-string sql-product) "]"))))
@@ -1528,7 +1740,7 @@ selected."
"Set `sql-product' to product and enable appropriate
highlighting."
(interactive "SEnter SQL product: ")
- (when (not (assoc product sql-product-support))
+ (when (not (assoc product sql-product-alist))
(error "SQL product %s is not supported; treated as ANSI" product)
(setq product 'ansi))
@@ -1952,6 +2164,19 @@ Every newline in STRING will be preceded with a space and a backslash."
(interactive)
(sql-send-region (point-min) (point-max)))
+(defun sql-send-string (str)
+ "Send a string to the SQL process."
+ (interactive "sSQL Text: ")
+ (if (buffer-live-p sql-buffer)
+ (save-excursion
+ (comint-send-string sql-buffer str)
+ (comint-send-string sql-buffer "\n")
+ (message "Sent string to buffer %s." (buffer-name sql-buffer))
+ (if sql-pop-to-buffer-after-send-region
+ (pop-to-buffer sql-buffer)
+ (display-buffer sql-buffer)))
+ (message "No SQL process started.")))
+
(defun sql-toggle-pop-to-buffer-after-send-region (&optional value)
"Toggle `sql-pop-to-buffer-after-send-region'.
@@ -2611,6 +2836,8 @@ parameters and command options."
(setq params (append params (list sql-database))))
(if (not (string= "" sql-server))
(setq params (append (list "-h" sql-server) params)))
+ (if (not (string= "" sql-user))
+ (setq params (append (list "-U" sql-user) params)))
(set-buffer (apply 'make-comint "SQL" sql-postgres-program
nil params))))
diff --git a/lisp/ps-print.el b/lisp/ps-print.el
index 50d7f1d2196..5c019b4f347 100644
--- a/lisp/ps-print.el
+++ b/lisp/ps-print.el
@@ -1262,7 +1262,7 @@ Please send all bug fixes and enhancements to
;; N-up printing.
;; Hook: `ps-print-begin-sheet-hook'.
;;
-;; [keinichi] 19990509 Kein'ichi Handa <handa@etl.go.jp>
+;; [kenichi] 19990509 Ken'ichi Handa <handa@m17n.org>
;;
;; `ps-print-region-function'
;;
@@ -1275,7 +1275,7 @@ Please send all bug fixes and enhancements to
;; PostScript prologue header comment insertion.
;; Skip invisible text better.
;;
-;; [keinichi] 19980819 Kein'ichi Handa <handa@etl.go.jp>
+;; [kenichi] 19980819 Ken'ichi Handa <handa@m17n.org>
;;
;; Multi-byte buffer handling.
;;
@@ -1383,7 +1383,7 @@ Please send all bug fixes and enhancements to
;; prologue code suggestion, for odd/even printing suggestion and for
;; `ps-prologue-file' enhancement.
;;
-;; Thanks to Kein'ichi Handa <handa@etl.go.jp> for multi-byte buffer handling.
+;; Thanks to Ken'ichi Handa <handa@m17n.org> for multi-byte buffer handling.
;;
;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on
;; empty columns.
@@ -3501,6 +3501,11 @@ The table depends on the current ps-print setup."
#'ps-print-quote
(list
(concat "\n;;; ps-print version " ps-print-version "\n")
+ ";; internal vars"
+ (ps-comment-string "ps-print-emacs-type" ps-print-emacs-type)
+ (ps-comment-string "ps-windows-system " ps-windows-system)
+ (ps-comment-string "ps-lp-system " ps-lp-system)
+ nil
'(25 . ps-print-color-p)
'(25 . ps-lpr-command)
'(25 . ps-lpr-switches)
@@ -3657,14 +3662,28 @@ If `ps-prefix-quote' is nil, it's set to t after generating string."
(if (> col len)
(make-string (- col len) ?\ )
" ")
- (cond ((null val) "nil")
- ((eq val t) "t")
- ((or (symbolp val) (listp val)) (format "'%S" val))
- (t (format "%S" val))))))
+ (ps-value-string val))))
(t "")
))
+(defun ps-value-string (val)
+ "Return a string representation of VAL. Used by `ps-print-quote'."
+ (cond ((null val)
+ "nil")
+ ((eq val t)
+ "t")
+ ((or (symbolp val) (listp val))
+ (format "'%S" val))
+ (t
+ (format "%S" val))))
+
+
+(defun ps-comment-string (str value)
+ "Return a comment string like \";; STR = VALUE\"."
+ (format ";; %s = %s" str (ps-value-string value)))
+
+
(defun ps-value (alist-sym key)
"Return value from association list ALIST-SYM which car is `eq' to KEY."
(cdr (assq key (symbol-value alist-sym))))
@@ -3718,8 +3737,8 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'."
(format-time-string "%Y-%m-%d"))
-(defalias 'ps-time-stamp-iso8601 'ps-time-stamp-yyyy-mm-dd
- "Alias for `ps-time-stamp-yyyy-mm-dd' (which see).")
+;; Alias for `ps-time-stamp-yyyy-mm-dd' (which see).
+(defalias 'ps-time-stamp-iso8601 'ps-time-stamp-yyyy-mm-dd)
(defun ps-time-stamp-hh:mm:ss ()
diff --git a/lisp/recentf.el b/lisp/recentf.el
index 7e379822457..efe4ebc63a4 100644
--- a/lisp/recentf.el
+++ b/lisp/recentf.el
@@ -1137,13 +1137,16 @@ default."
"Save the recent list.
Write data into the file specified by `recentf-save-file'."
(interactive)
- (with-temp-buffer
- (erase-buffer)
- (insert (format recentf-save-file-header (current-time-string)))
- (recentf-dump-variable 'recentf-list recentf-max-saved-items)
- (recentf-dump-variable 'recentf-filter-changer-state)
- (write-file (expand-file-name recentf-save-file))
- nil))
+ (condition-case error
+ (with-temp-buffer
+ (erase-buffer)
+ (insert (format recentf-save-file-header (current-time-string)))
+ (recentf-dump-variable 'recentf-list recentf-max-saved-items)
+ (recentf-dump-variable 'recentf-filter-changer-state)
+ (write-file (expand-file-name recentf-save-file))
+ nil)
+ (error
+ (warn "recentf mode: %s" (error-message-string error)))))
(defun recentf-load-list ()
"Load a previously saved recent list.
diff --git a/lisp/replace.el b/lisp/replace.el
index 2d26cb5cc66..89f55c2829e 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -1,7 +1,7 @@
;;; replace.el --- replace commands for Emacs
-;; Copyright (C) 1985, 86, 87, 92, 94, 96, 1997, 2000, 2001, 2002
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 87, 92, 94, 96, 1997, 2000, 2001, 2002,
+;; 2003, 2004 Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -36,9 +36,11 @@
(defvar query-replace-history nil)
-(defvar query-replace-interactive nil
+(defcustom query-replace-interactive nil
"Non-nil means `query-replace' uses the last search string.
-That becomes the \"string to replace\".")
+That becomes the \"string to replace\"."
+ :type 'boolean
+ :group 'matching)
(defcustom query-replace-from-history-variable 'query-replace-history
"History list to use for the FROM argument of `query-replace' commands.
@@ -79,14 +81,15 @@ strings or patterns."
query-replace-from-history-variable
nil t)))
;; Warn if user types \n or \t, but don't reject the input.
- (if (string-match "\\\\[nt]" from)
- (let ((match (match-string 0 from)))
- (cond
- ((string= match "\\n")
- (message "Note: `\\n' here doesn't match a newline; to do that, type C-q C-j instead"))
- ((string= match "\\t")
- (message "Note: `\\t' here doesn't match a tab; to do that, just type TAB")))
- (sit-for 2))))
+ (and regexp-flag
+ (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\(\\\\[nt]\\)" from)
+ (let ((match (match-string 3 from)))
+ (cond
+ ((string= match "\\n")
+ (message "Note: `\\n' here doesn't match a newline; to do that, type C-q C-j instead"))
+ ((string= match "\\t")
+ (message "Note: `\\t' here doesn't match a tab; to do that, just type TAB")))
+ (sit-for 2))))
(save-excursion
(setq to (read-from-minibuffer (format "%s %s with: " string from)
@@ -159,20 +162,62 @@ Fourth and fifth arg START and END specify the region to operate on.
In TO-STRING, `\\&' stands for whatever matched the whole of REGEXP,
and `\\=\\N' (where N is a digit) stands for
- whatever what matched the Nth `\\(...\\)' in REGEXP."
+whatever what matched the Nth `\\(...\\)' in REGEXP.
+
+When this function is called interactively, the replacement text
+can also contain `\\,' followed by a Lisp expression. The escaped
+shorthands for `query-replace-regexp-eval' are also valid
+here: within the Lisp expression, you can use `\\&' for the whole
+match string, `\\N' for partial matches, `\\#&' and `\\#N' for
+the respective numeric values, and `\\#' for `replace-count'.
+
+If your Lisp expression is an identifier and the next
+letter in the replacement string would be interpreted as part of it,
+you can wrap it with an expression like `\\,(or \\#)'. Incidentally,
+for this particular case you may also enter `\\#' in the replacement
+text directly.
+
+When you use `\\,' or `\\#' in the replacement, TO-STRING actually
+becomes a list with expanded shorthands.
+Use \\[repeat-complex-command] after this command to see details."
(interactive
(let ((common
(query-replace-read-args "Query replace regexp" t)))
- (list (nth 0 common) (nth 1 common) (nth 2 common)
- ;; These are done separately here
- ;; so that command-history will record these expressions
- ;; rather than the values they had this time.
- (if (and transient-mark-mode mark-active)
- (region-beginning))
- (if (and transient-mark-mode mark-active)
- (region-end)))))
-
+ (list
+ (nth 0 common)
+ (if (string-match "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\\\[,#]"
+ (nth 1 common))
+ (let ((to-string (nth 1 common)) pos to-expr char prompt)
+ (while (string-match
+ "\\(\\`\\|[^\\]\\)\\(\\\\\\\\\\)*\\\\[,#]"
+ to-string)
+ (setq pos (match-end 0))
+ (push (substring to-string 0 (- pos 2)) to-expr)
+ (setq char (aref to-string (1- pos))
+ to-string (substring to-string pos))
+ (cond ((eq char ?\#)
+ (push '(number-to-string replace-count) to-expr))
+ ((eq char ?\,)
+ (setq pos (read-from-string to-string))
+ (push `(replace-quote ,(car pos)) to-expr)
+ (setq to-string (substring to-string (cdr pos))))))
+ (setq to-expr (nreverse (delete "" (cons to-string to-expr))))
+ (replace-match-string-symbols to-expr)
+ (cons 'replace-eval-replacement
+ (if (> (length to-expr) 1)
+ (cons 'concat to-expr)
+ (car to-expr))))
+ (nth 1 common))
+ (nth 2 common)
+ ;; These are done separately here
+ ;; so that command-history will record these expressions
+ ;; rather than the values they had this time.
+ (if (and transient-mark-mode mark-active)
+ (region-beginning))
+ (if (and transient-mark-mode mark-active)
+ (region-end)))))
(perform-replace regexp to-string t t delimited nil nil start end))
+
(define-key esc-map [?\C-%] 'query-replace-regexp)
(defun query-replace-regexp-eval (regexp to-expr &optional delimited start end)
@@ -189,6 +234,7 @@ For convenience, when entering TO-EXPR interactively, you can use `\\&' or
`\\0' to stand for whatever matched the whole of REGEXP, and `\\N' (where
N is a digit) to stand for whatever matched the Nth `\\(...\\)' in REGEXP.
Use `\\#&' or `\\#N' if you want a number instead of a string.
+In interactive use, `\\#' in itself stands for `replace-count'.
In Transient Mark mode, if the mark is active, operate on the contents
of the region. Otherwise, operate from point to the end of the buffer.
@@ -538,6 +584,7 @@ Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it.
(set (make-local-variable 'revert-buffer-function) 'occur-revert-function)
(make-local-variable 'occur-revert-arguments)
(add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
+ (setq next-error-function 'occur-next-error)
(run-hooks 'occur-mode-hook))
(defun occur-revert-function (ignore1 ignore2)
@@ -614,6 +661,21 @@ Alternatively, click \\[occur-mode-mouse-goto] on an item to go to it.
"Move to the Nth (default 1) previous match in an Occur mode buffer."
(interactive "p")
(occur-find-match n #'previous-single-property-change "No earlier matches"))
+
+(defun occur-next-error (&optional argp reset)
+ "Move to the Nth (default 1) next match in an Occur mode buffer.
+Compatibility function for \\[next-error] invocations."
+ (interactive "p")
+ (when reset
+ (occur-find-match 0 #'next-single-property-change "No first match"))
+ (occur-find-match
+ (prefix-numeric-value argp)
+ (if (> 0 (prefix-numeric-value argp))
+ #'previous-single-property-change
+ #'next-single-property-change)
+ "No more matches")
+ (occur-mode-goto-occurrence))
+
(defcustom list-matching-lines-default-context-lines 0
"*Default number of context lines included around `list-matching-lines' matches.
@@ -800,7 +862,9 @@ See also `multi-occur'."
(setq occur-revert-arguments (list regexp nlines bufs)
buffer-read-only t)
(if (> count 0)
- (display-buffer occur-buf)
+ (progn
+ (display-buffer occur-buf)
+ (setq next-error-last-buffer occur-buf))
(kill-buffer occur-buf)))
(run-hooks 'occur-hook))))
@@ -992,6 +1056,7 @@ N (match-string N) (where N is a string of digits)
#N (string-to-number (match-string N))
& (match-string 0)
#& (string-to-number (match-string 0))
+# replace-count
Note that these symbols must be preceeded by a backslash in order to
type them."
@@ -1011,7 +1076,9 @@ type them."
((string= "&" name)
(setcar n '(match-string 0)))
((string= "#&" name)
- (setcar n '(string-to-number (match-string 0))))))))
+ (setcar n '(string-to-number (match-string 0))))
+ ((string= "#" name)
+ (setcar n 'replace-count))))))
(setq n (cdr n))))
(defun replace-eval-replacement (expression replace-count)
@@ -1020,6 +1087,21 @@ type them."
replacement
(prin1-to-string replacement t))))
+(defun replace-quote (replacement)
+ "Quote a replacement string.
+This just doubles all backslashes in REPLACEMENT and
+returns the resulting string. If REPLACEMENT is not
+a string, it is first passed through `prin1-to-string'
+with the `noescape' argument set.
+
+`match-data' is preserved across the call."
+ (save-match-data
+ (replace-regexp-in-string "\\\\" "\\\\"
+ (if (stringp replacement)
+ replacement
+ (prin1-to-string replacement t))
+ t t)))
+
(defun replace-loop-through-replacements (data replace-count)
;; DATA is a vector contaning the following values:
;; 0 next-rotate-count
@@ -1112,7 +1194,7 @@ make, or the user didn't cancel the call."
(unwind-protect
;; Loop finding occurrences that perhaps should be replaced.
(while (and keep-going
- (not (eobp))
+ (not (or (eobp) (and limit (>= (point) limit))))
;; Use the next match if it is already known;
;; otherwise, search for a match after moving forward
;; one char if progress is required.
@@ -1128,7 +1210,10 @@ make, or the user didn't cancel the call."
;; character too far at the end,
;; but this is undone after the
;; while-loop.
- (progn (forward-char 1) (not (eobp))))
+ (progn
+ (forward-char 1)
+ (not (or (eobp)
+ (and limit (>= (point) limit))))))
(funcall search-function search-string limit t)
;; For speed, use only integers and
;; reuse the list used last time.
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 3e40f118a41..249bdfe00e3 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -207,7 +207,9 @@ may have changed\) back to `save-place-alist'."
(delete-region (point-min) (point-max))
(when save-place-forget-unreadable-files
(save-place-forget-unreadable-files))
- (print save-place-alist (current-buffer))
+ (let ((print-length nil)
+ (print-level nil))
+ (print save-place-alist (current-buffer)))
(let ((version-control
(cond
((null save-place-version-control) nil)
diff --git a/lisp/sb-dir-minus.xpm b/lisp/sb-dir-minus.xpm
index 30dcd753505..0bb8a9cd897 100644
--- a/lisp/sb-dir-minus.xpm
+++ b/lisp/sb-dir-minus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_dir__xpm[] = {
-"20 15 4 1",
+static char * sb_dir_minus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
-" ....... ",
-".+++++++. ",
-".+@@@@@@+.......... ",
-".+@@@@@@@++++++++++.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@++++++@@@@@+.",
-".+@@@@@++++++@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+"# c #828282",
+" ...... ",
+" .++++++. ",
+".+@@@@@@+......... ",
+".+@@@@@@@+++++++++. ",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@+++++@@@@@@+#",
+".+@@@@@@.....@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+" #++++++++++++++++# ",
+" ################ "};
diff --git a/lisp/sb-dir-plus.xpm b/lisp/sb-dir-plus.xpm
index 4289abc0e43..009719bce6d 100644
--- a/lisp/sb-dir-plus.xpm
+++ b/lisp/sb-dir-plus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_dir+_xpm[] = {
-"20 15 4 1",
+static char * sb_dir_plus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
-" ....... ",
-".+++++++. ",
-".+@@@@@@+.......... ",
-".+@@@@@@@++++++++++.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@@@@@++++++@@@@@+.",
-".+@@@@@++++++@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+"# c #828282",
+" ...... ",
+" .++++++. ",
+".+@@@@@@+......... ",
+".+@@@@@@@+++++++++. ",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@+@@@@@@@@+#",
+".+@@@@@@@+.@@@@@@@+#",
+".+@@@@@+++++@@@@@@+#",
+".+@@@@@@.+...@@@@@+#",
+".+@@@@@@@+.@@@@@@@+#",
+".+@@@@@@@@.@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+" #++++++++++++++++# ",
+" ################ "};
diff --git a/lisp/sb-dir.xpm b/lisp/sb-dir.xpm
index 622ce19e937..1c3d3d72b87 100644
--- a/lisp/sb-dir.xpm
+++ b/lisp/sb-dir.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_dir_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
-" ....... ",
-".+++++++. ",
-".+@@@@@@+.......... ",
-".+@@@@@@@++++++++++.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+"# c #828282",
+" ...... ",
+" .++++++. ",
+".+@@@@@@+......... ",
+".+@@@@@@@+++++++++. ",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+" #++++++++++++++++# ",
+" ################ "};
diff --git a/lisp/sb-mail.xpm b/lisp/sb-mail.xpm
index 5716eeb9661..fecc0a1aa38 100644
--- a/lisp/sb-mail.xpm
+++ b/lisp/sb-mail.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_mail_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
-"@ c #FFFFFF",
-"................... ",
-".++++++++++++++++++.",
-".++@@@@@@@@@@@@@@++.",
-".+@++@@@@@@@@@@++@+.",
-".+@@@++@@@@@@++@@@+.",
-".+@@@@@++@@++@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@+@@@@@@+@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@+@@@@@@@@@@+@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++@@@@@@@@@@@@@@++.",
-".++++++++++++++++++.",
-" .................. "};
+"@ c #828282",
+"# c #FFFFFF",
+" .................. ",
+".++++++++++++++++++@",
+".++##############++@",
+".+#++##########++#+@",
+".+###++######++###+@",
+".+#####++##++#####+@",
+".+#######++#######+@",
+".+################+@",
+".+####+######+####+@",
+".+################+@",
+".+##+##########+##+@",
+".+################+@",
+".++##############++@",
+".++++++++++++++++++@",
+" @@@@@@@@@@@@@@@@@@ "};
diff --git a/lisp/sb-pg-minus.xpm b/lisp/sb-pg-minus.xpm
index 63230ef1c0a..e512d25120a 100644
--- a/lisp/sb-pg-minus.xpm
+++ b/lisp/sb-pg-minus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_file__xpm[] = {
-"20 15 4 1",
+static char * sb_pg_minus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
-"@ c #FFFFFF",
+"@ c #828282",
+"# c #FFFFFF",
" ............ ",
-" .++++++++++++.",
-" .++@@@@@@@@@@+.",
-" .+@+@@@@@@@@@@+.",
-" .+@@+@@@@@@@@@@+.",
-" .+@@@+@@@@@@@@@@+.",
-" .+@@@@+@@@@@@@@@@+.",
-".+++++++@++++++@@@+.",
-".+@@@@@@@++++++@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+" .++++++++++++@",
+" .++##########+@",
+" .+#+##########+@",
+" .+##+##########+@",
+" .+###+##########+@",
+" .+####+##########+@",
+".+++++++#+++++####+@",
+".+########.....###+@",
+".+################+@",
+".+################+@",
+".+################+@",
+".+################+@",
+".++++++++++++++++++@",
+" @@@@@@@@@@@@@@@@@@ "};
diff --git a/lisp/sb-pg-plus.xpm b/lisp/sb-pg-plus.xpm
index 0cd4ce81299..f0e74678249 100644
--- a/lisp/sb-pg-plus.xpm
+++ b/lisp/sb-pg-plus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_file+_xpm[] = {
-"20 15 4 1",
+static char * sb_pg_plus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
-"@ c #FFFFFF",
+"@ c #828282",
+"# c #FFFFFF",
" ............ ",
-" .++++++++++++.",
-" .++@@@@@@@@@@+.",
-" .+@+@@@@@@@@@@+.",
-" .+@@+@@@@@@@@@@+.",
-" .+@@@+@@@++@@@@@+.",
-" .+@@@@+@@@++@@@@@+.",
-".+++++++@++++++@@@+.",
-".+@@@@@@@++++++@@@+.",
-".+@@@@@@@@@++@@@@@+.",
-".+@@@@@@@@@++@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+" .++++++++++++@",
+" .++##########+@",
+" .+#+##########+@",
+" .+##+##########+@",
+" .+###+###+######+@",
+" .+####+###+.#####+@",
+".+++++++#+++++####+@",
+".+########.+...###+@",
+".+#########+.#####+@",
+".+##########.#####+@",
+".+################+@",
+".+################+@",
+".++++++++++++++++++@",
+" @@@@@@@@@@@@@@@@@@ "};
diff --git a/lisp/sb-pg.xpm b/lisp/sb-pg.xpm
index 241767abbdf..3a210bfa897 100644
--- a/lisp/sb-pg.xpm
+++ b/lisp/sb-pg.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_file_xpm[] = {
-"20 15 4 1",
+static char * sb_pg_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
-"@ c #FFFFFF",
+"@ c #828282",
+"# c #FFFFFF",
" ............ ",
-" .++++++++++++.",
-" .++@@@@@@@@@@+.",
-" .+@+@@@@@@@@@@+.",
-" .+@@+@@@@@@@@@@+.",
-" .+@@@+@@@@@@@@@@+.",
-" .+@@@@+@@@@@@@@@@+.",
-".+++++++@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".++++++++++++++++++.",
-" .................. "};
+" .++++++++++++@",
+" .++##########+@",
+" .+#+##########+@",
+" .+##+##########+@",
+" .+###+##########+@",
+" .+####+##########+@",
+".+++++++##########+@",
+".+################+@",
+".+################+@",
+".+################+@",
+".+################+@",
+".+################+@",
+".++++++++++++++++++@",
+" @@@@@@@@@@@@@@@@@@ "};
diff --git a/lisp/sb-tag-gt.xpm b/lisp/sb-tag-gt.xpm
index 49b8b72a2c1..9db11a13e8f 100644
--- a/lisp/sb-tag-gt.xpm
+++ b/lisp/sb-tag-gt.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_tag_gt_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@++@@@@@@@+.",
-" .+@@@@@@+++@@@@@@+.",
-".+@@@@@@@++++@@@@@+.",
-".+@++@@@@+++++@@@@+.",
-".+@++@@@@+++++.@@@+.",
-".+@@@@@@@++++.@@@@+.",
-" .+@@@@@@+++.@@@@@+.",
-" .+@@@@@++.@@@@@@+.",
-". .++++++.++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@++@@@@@@@+#",
+" .+@@@@@@+++@@@@@@+#",
+".+@@@@@@@++++@@@@@+#",
+".+@++@@@@+++++@@@@+#",
+".+@++@@@@+++++#@@@+#",
+".+@@@@@@@++++#@@@@+#",
+" #+@@@@@@+++#@@@@@+#",
+" #+@@@@@++#@@@@@@+#",
+" #++++++#+++++++# ",
+" ############## ",
" "};
diff --git a/lisp/sb-tag-minus.xpm b/lisp/sb-tag-minus.xpm
index f006c4ef4cb..560aaa3aa82 100644
--- a/lisp/sb-tag-minus.xpm
+++ b/lisp/sb-tag-minus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_tag__xpm[] = {
-"20 15 4 1",
+static char * sb_tag_minus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@++@@++++++@@@@@+.",
-".+@++@@++++++@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@+.",
-". .+++++++++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@@@@@@@@@@+#",
+" .+@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@++@@+++++@@@@@@+#",
+".+@++@@@.....@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+" #+@@@@@@@@@@@@@@@+#",
+" #+@@@@@@@@@@@@@@+#",
+" #++++++++++++++# ",
+" ############## ",
" "};
diff --git a/lisp/sb-tag-plus.xpm b/lisp/sb-tag-plus.xpm
index cf32fef549c..3dcf2f87c5d 100644
--- a/lisp/sb-tag-plus.xpm
+++ b/lisp/sb-tag-plus.xpm
@@ -1,22 +1,23 @@
/* XPM */
-static char * sb_tag+_xpm[] = {
-"20 15 4 1",
+static char * sb_tag_plus_xpm[] = {
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@@@@@@@@@@+.",
-" .+@@@@@@++@@@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-".+@++@@++++++@@@@@+.",
-".+@++@@++++++@@@@@+.",
-".+@@@@@@@++@@@@@@@+.",
-" .+@@@@@@++@@@@@@@+.",
-" .+@@@@@@@@@@@@@@+.",
-". .+++++++++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@@@@@@@@@@+#",
+" .+@@@@@@+@@@@@@@@+#",
+".+@@@@@@@+.@@@@@@@+#",
+".+@++@@+++++@@@@@@+#",
+".+@++@@@.+...@@@@@+#",
+".+@@@@@@@+.@@@@@@@+#",
+" #+@@@@@@@.@@@@@@@+#",
+" #+@@@@@@@@@@@@@@+#",
+" #++++++++++++++# ",
+" ############## ",
" "};
diff --git a/lisp/sb-tag-type.xpm b/lisp/sb-tag-type.xpm
index 65886989dbd..3abe408a66b 100644
--- a/lisp/sb-tag-type.xpm
+++ b/lisp/sb-tag-type.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_tag_type_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@@@@@@@@@@+.",
-" .+@@@@@@++++++@@@+.",
-".+@@@@@@@++++++@@@+.",
-".+@++@@@@@@++@@@@@+.",
-".+@++@@@@@@++@@@@@+.",
-".+@@@@@@@@@++@@@@@+.",
-" .+@@@@@@@@++@@@@@+.",
-" .+@@@@@@@@@@@@@@+.",
-". .+++++++++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@@@@@@@@@@+#",
+" .+@@@@@@++++++@@@+#",
+".+@@@@@@@++++++@@@+#",
+".+@++@@@@@@++@@@@@+#",
+".+@++@@@@@@++@@@@@+#",
+".+@@@@@@@@@++@@@@@+#",
+" #+@@@@@@@@++@@@@@+#",
+" #+@@@@@@@@@@@@@@+#",
+" #++++++++++++++# ",
+" ############## ",
" "};
diff --git a/lisp/sb-tag-v.xpm b/lisp/sb-tag-v.xpm
index 7431e4c5d87..ae447adc8e4 100644
--- a/lisp/sb-tag-v.xpm
+++ b/lisp/sb-tag-v.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_tag_v_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@@@@@@@@@@+.",
-" .+@@@++++++++++.@+.",
-".+@@@@@++++++++.@@+.",
-".+@++@@@++++++.@@@+.",
-".+@++@@@@++++.@@@@+.",
-".+@@@@@@@@++.@@@@@+.",
-" .+@@@@@@@@.@@@@@@+.",
-" .+@@@@@@@@@@@@@@+.",
-". .+++++++++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@@@@@@@@@@+#",
+" .+@@@++++++++++#@+#",
+".+@@@@@++++++++#@@+#",
+".+@++@@@++++++#@@@+#",
+".+@++@@@@++++#@@@@+#",
+".+@@@@@@@@++#@@@@@+#",
+" #+@@@@@@@@#@@@@@@+#",
+" #+@@@@@@@@@@@@@@+#",
+" #++++++++++++++# ",
+" ############## ",
" "};
diff --git a/lisp/sb-tag.xpm b/lisp/sb-tag.xpm
index 4c6f1c56c1f..900bfd34b26 100644
--- a/lisp/sb-tag.xpm
+++ b/lisp/sb-tag.xpm
@@ -1,22 +1,23 @@
/* XPM */
static char * sb_tag_xpm[] = {
-"20 15 4 1",
+"20 15 5 1",
" c None",
-". c #828282",
+". c #B8B8B8",
"+ c #000000",
"@ c #FFF993",
+"# c #828282",
" ",
" ",
-" ............... ",
-" .+++++++++++++++.",
-" .+@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-".+@++@@@@@@@@@@@@@+.",
-".+@++@@@@@@@@@@@@@+.",
-".+@@@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@@+.",
-" .+@@@@@@@@@@@@@@+.",
-". .+++++++++++++++.",
-" ............... ",
+" .............. ",
+" .++++++++++++++. ",
+" .+@@@@@@@@@@@@@@+#",
+" .+@@@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+".+@++@@@@@@@@@@@@@+#",
+".+@++@@@@@@@@@@@@@+#",
+".+@@@@@@@@@@@@@@@@+#",
+" #+@@@@@@@@@@@@@@@+#",
+" #+@@@@@@@@@@@@@@+#",
+" #++++++++++++++# ",
+" ############## ",
" "};
diff --git a/lisp/select.el b/lisp/select.el
index 01b227d8712..c095ea50c44 100644
--- a/lisp/select.el
+++ b/lisp/select.el
@@ -176,47 +176,48 @@ Cut buffers are considered obsolete; you should use selections instead."
(if coding
(setq coding (coding-system-base coding))
(setq coding 'raw-text))
- ;; Suppress producing escape sequences for compositions.
- (remove-text-properties 0 (length str) '(composition nil) str)
- (cond
- ((eq type 'TEXT)
- (if (not (multibyte-string-p str))
- ;; Don't have to encode unibyte string.
- (setq type 'STRING)
- ;; If STR contains only ASCII, Latin-1, and raw bytes,
- ;; encode STR by iso-latin-1, and return it as type
- ;; `STRING'. Otherwise, encode STR by CODING. In that
- ;; case, the returing type depends on CODING.
- (let ((charsets (find-charset-string str)))
- (setq charsets
- (delq 'ascii
- (delq 'latin-iso8859-1
- (delq 'eight-bit-control
- (delq 'eight-bit-graphic charsets)))))
- (if charsets
- (setq str (encode-coding-string str coding)
- type (if (memq coding '(compound-text
- compound-text-with-extensions))
- 'COMPOUND_TEXT
- 'STRING))
- (setq type 'STRING
- str (encode-coding-string str 'iso-latin-1))))))
-
- ((eq type 'COMPOUND_TEXT)
- (setq str (encode-coding-string str coding)))
-
- ((eq type 'STRING)
- (if (memq coding '(compound-text
- compound-text-with-extensions))
- (setq str (string-make-unibyte str))
- (setq str (encode-coding-string str coding))))
-
- ((eq type 'UTF8_STRING)
- (setq str (encode-coding-string str 'utf-8)))
-
- (t
- (error "Unknow selection type: %S" type))
- ))
+ (let ((inhibit-read-only t))
+ ;; Suppress producing escape sequences for compositions.
+ (remove-text-properties 0 (length str) '(composition nil) str)
+ (cond
+ ((eq type 'TEXT)
+ (if (not (multibyte-string-p str))
+ ;; Don't have to encode unibyte string.
+ (setq type 'STRING)
+ ;; If STR contains only ASCII, Latin-1, and raw bytes,
+ ;; encode STR by iso-latin-1, and return it as type
+ ;; `STRING'. Otherwise, encode STR by CODING. In that
+ ;; case, the returing type depends on CODING.
+ (let ((charsets (find-charset-string str)))
+ (setq charsets
+ (delq 'ascii
+ (delq 'latin-iso8859-1
+ (delq 'eight-bit-control
+ (delq 'eight-bit-graphic charsets)))))
+ (if charsets
+ (setq str (encode-coding-string str coding)
+ type (if (memq coding '(compound-text
+ compound-text-with-extensions))
+ 'COMPOUND_TEXT
+ 'STRING))
+ (setq type 'STRING
+ str (encode-coding-string str 'iso-latin-1))))))
+
+ ((eq type 'COMPOUND_TEXT)
+ (setq str (encode-coding-string str coding)))
+
+ ((eq type 'STRING)
+ (if (memq coding '(compound-text
+ compound-text-with-extensions))
+ (setq str (string-make-unibyte str))
+ (setq str (encode-coding-string str coding))))
+
+ ((eq type 'UTF8_STRING)
+ (setq str (encode-coding-string str 'utf-8)))
+
+ (t
+ (error "Unknow selection type: %S" type))
+ )))
(setq next-selection-coding-system nil)
(cons type str))))
diff --git a/lisp/ses.el b/lisp/ses.el
index a5cc6bf657c..9439d98c481 100644
--- a/lisp/ses.el
+++ b/lisp/ses.el
@@ -983,7 +983,7 @@ be set to VALUE."
(ses-aset-with-undo (symbol-value def) elem value)
(ses-set-with-undo def value))
(let ((inhibit-read-only t)
- (fmt (plist-get '(ses--column-widths "(ses-column-widths %S)"
+ (fmt (plist-get '(ses--col-widths "(ses-column-widths %S)"
ses--col-printers "(ses-column-printers %S)"
ses--default-printer "(ses-default-printer %S)"
ses--header-row "(ses-header-row %S)"
diff --git a/lisp/simple.el b/lisp/simple.el
index 2d0a176de0c..8da9e8028f0 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1,7 +1,7 @@
;;; simple.el --- basic editing commands for Emacs
;; Copyright (C) 1985, 86, 87, 93, 94, 95, 96, 97, 98, 99,
-;; 2000, 2001, 2002, 2003
+;; 2000, 01, 02, 03, 04
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -37,7 +37,7 @@
(defgroup killing nil
- "Killing and yanking commands"
+ "Killing and yanking commands."
:group 'editing)
(defgroup paren-matching nil
@@ -66,6 +66,154 @@
(setq list (cdr list)))
(switch-to-buffer found)))
+;;; next-error support framework
+(defvar next-error-last-buffer nil
+ "The most recent next-error buffer.
+A buffer becomes most recent when its compilation, grep, or
+similar mode is started, or when it is used with \\[next-error]
+or \\[compile-goto-error].")
+
+(defvar next-error-function nil
+ "Function to use to find the next error in the current buffer.
+The function is called with 2 parameters:
+ARG is an integer specifying by how many errors to move.
+RESET is a boolean which, if non-nil, says to go back to the beginning
+of the errors before moving.
+Major modes providing compile-like functionality should set this variable
+to indicate to `next-error' that this is a candidate buffer and how
+to navigate in it.")
+
+(make-variable-buffer-local 'next-error-function)
+
+(defsubst next-error-buffer-p (buffer &optional extra-test)
+ "Test if BUFFER is a next-error capable buffer."
+ (with-current-buffer buffer
+ (or (and extra-test (funcall extra-test))
+ next-error-function)))
+
+;; Return a next-error capable buffer according to the following rules:
+;; 1. If the current buffer is a next-error capable buffer, return it.
+;; 2. If one window on the selected frame displays such buffer, return it.
+;; 3. If next-error-last-buffer is set to a live buffer, use that.
+;; 4. Otherwise, look for a next-error capable buffer in a buffer list.
+;; 5. Signal an error if there are none.
+(defun next-error-find-buffer (&optional other-buffer extra-test)
+ (if (and (not other-buffer)
+ (next-error-buffer-p (current-buffer) extra-test))
+ ;; The current buffer is a next-error capable buffer.
+ (current-buffer)
+ (or
+ (let ((window-buffers
+ (delete-dups
+ (delq nil
+ (mapcar (lambda (w)
+ (and (next-error-buffer-p (window-buffer w) extra-test)
+ (window-buffer w)))
+ (window-list))))))
+ (if other-buffer
+ (setq window-buffers (delq (current-buffer) window-buffers)))
+ (if (eq (length window-buffers) 1)
+ (car window-buffers)))
+ (if (and next-error-last-buffer (buffer-name next-error-last-buffer)
+ (next-error-buffer-p next-error-last-buffer extra-test)
+ (or (not other-buffer) (not (eq next-error-last-buffer
+ (current-buffer)))))
+ next-error-last-buffer
+ (let ((buffers (buffer-list)))
+ (while (and buffers (or (not (next-error-buffer-p (car buffers) extra-test))
+ (and other-buffer
+ (eq (car buffers) (current-buffer)))))
+ (setq buffers (cdr buffers)))
+ (if buffers
+ (car buffers)
+ (or (and other-buffer
+ (next-error-buffer-p (current-buffer) extra-test)
+ ;; The current buffer is a next-error capable buffer.
+ (progn
+ (if other-buffer
+ (message "This is the only next-error capable buffer."))
+ (current-buffer)))
+ (error "No next-error capable buffer found"))))))))
+
+(defun next-error (arg &optional reset)
+ "Visit next next-error message and corresponding source code.
+
+If all the error messages parsed so far have been processed already,
+the message buffer is checked for new ones.
+
+A prefix ARG specifies how many error messages to move;
+negative means move back to previous error messages.
+Just \\[universal-argument] as a prefix means reparse the error message buffer
+and start at the first error.
+
+The RESET argument specifies that we should restart from the beginning.
+
+\\[next-error] normally uses the most recently started
+compilation, grep, or occur buffer. It can also operate on any
+buffer with output from the \\[compile], \\[grep] commands, or,
+more generally, on any buffer in Compilation mode or with
+Compilation Minor mode enabled, or any buffer in which
+`next-error-function' is bound to an appropriate
+function. To specify use of a particular buffer for error
+messages, type \\[next-error] in that buffer.
+
+Once \\[next-error] has chosen the buffer for error messages,
+it stays with that buffer until you use it in some other buffer which
+uses Compilation mode or Compilation Minor mode.
+
+See variables `compilation-parse-errors-function' and
+\`compilation-error-regexp-alist' for customization ideas."
+ (interactive "P")
+ (if (consp arg) (setq reset t arg nil))
+ (when (setq next-error-last-buffer (next-error-find-buffer))
+ ;; we know here that next-error-function is a valid symbol we can funcall
+ (with-current-buffer next-error-last-buffer
+ (funcall next-error-function (prefix-numeric-value arg) reset))))
+
+(defalias 'goto-next-locus 'next-error)
+(defalias 'next-match 'next-error)
+
+(define-key ctl-x-map "`" 'next-error)
+
+(defun previous-error (n)
+ "Visit previous next-error message and corresponding source code.
+
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+
+This operates on the output from the \\[compile] and \\[grep] commands."
+ (interactive "p")
+ (next-error (- n)))
+
+(defun first-error (n)
+ "Restart at the first error.
+Visit corresponding source code.
+With prefix arg N, visit the source code of the Nth error.
+This operates on the output from the \\[compile] command, for instance."
+ (interactive "p")
+ (next-error n t))
+
+(defun next-error-no-select (n)
+ "Move point to the next error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move forwards (or
+backwards, if negative).
+Finds and highlights the source line like \\[next-error], but does not
+select the source buffer."
+ (interactive "p")
+ (next-error n)
+ (pop-to-buffer next-error-last-buffer))
+
+(defun previous-error-no-select (n)
+ "Move point to the previous error in the next-error buffer and highlight match.
+Prefix arg N says how many error messages to move backwards (or
+forwards, if negative).
+Finds and highlights the source line like \\[previous-error], but does not
+select the source buffer."
+ (interactive "p")
+ (next-error-no-select (- n)))
+
+;;;
+
(defun fundamental-mode ()
"Major mode not specialized for anything in particular.
Other major modes are defined by comparison with this one."
@@ -159,7 +307,7 @@ than the value of `fill-column' and ARG is nil."
(put-text-property from (point) 'rear-nonsticky
(cons 'hard sticky)))))
-(defun open-line (arg)
+(defun open-line (n)
"Insert a newline and leave point before it.
If there is a fill prefix and/or a left-margin, insert them on the new line
if the line would have been blank.
@@ -170,23 +318,23 @@ With arg N, insert N newlines."
(loc (point))
;; Don't expand an abbrev before point.
(abbrev-mode nil))
- (newline arg)
+ (newline n)
(goto-char loc)
- (while (> arg 0)
+ (while (> n 0)
(cond ((bolp)
(if do-left-margin (indent-to (current-left-margin)))
(if do-fill-prefix (insert-and-inherit fill-prefix))))
(forward-line 1)
- (setq arg (1- arg)))
+ (setq n (1- n)))
(goto-char loc)
(end-of-line)))
(defun split-line (&optional arg)
"Split current line, moving portion beyond point vertically down.
If the current line starts with `fill-prefix', insert it on the new
-line as well. With prefix arg, don't insert fill-prefix on new line.
+line as well. With prefix ARG, don't insert fill-prefix on new line.
-When called from Lisp code, the arg may be a prefix string to copy."
+When called from Lisp code, ARG may be a prefix string to copy."
(interactive "*P")
(skip-chars-forward " \t")
(let* ((col (current-column))
@@ -637,6 +785,23 @@ If nil, don't change the value of `debug-on-error'."
:type 'boolean
:version "21.1")
+(defun eval-expression-print-format (value)
+ "Format VALUE as a result of evaluated expression.
+Return a formatted string which is displayed in the echo area
+in addition to the value printed by prin1 in functions which
+display the result of expression evaluation."
+ (if (and (integerp value)
+ (or (not (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+ (eq this-command last-command)
+ (and (boundp 'edebug-active) edebug-active)))
+ (let ((char-string
+ (if (or (and (boundp 'edebug-active) edebug-active)
+ (memq this-command '(eval-last-sexp eval-print-last-sexp)))
+ (prin1-char value))))
+ (if char-string
+ (format " (0%o, 0x%x) = %s" value value char-string)
+ (format " (0%o, 0x%x)" value value)))))
+
;; We define this, rather than making `eval' interactive,
;; for the sake of completion of names like eval-region, eval-current-buffer.
(defun eval-expression (eval-expression-arg
@@ -671,7 +836,10 @@ the echo area."
(with-no-warnings
(let ((standard-output (current-buffer)))
(eval-last-sexp-print-value (car values))))
- (prin1 (car values) t))))
+ (prog1
+ (prin1 (car values) t)
+ (let ((str (eval-expression-print-format (car values))))
+ (if str (princ str t)))))))
(defun edit-and-eval-command (prompt command)
"Prompting with PROMPT, let user edit COMMAND and eval result.
@@ -785,7 +953,8 @@ See also `minibuffer-history-case-insensitive-variables'."
nil
minibuffer-local-map
nil
- 'minibuffer-history-search-history)))
+ 'minibuffer-history-search-history
+ (car minibuffer-history-search-history))))
;; Use the last regexp specified, by default, if input is empty.
(list (if (string= regexp "")
(if minibuffer-history-search-history
@@ -987,7 +1156,7 @@ as an argument limits undo to changes within the current region."
(undo-start))
;; get rid of initial undo boundary
(undo-more 1))
- ;; If we got this far, the next command should be a consecutive undo.
+ ;; If we got this far, the next command should be a consecutive undo.
(setq this-command 'undo)
;; Check to see whether we're hitting a redo record, and if
;; so, ask the user whether she wants to skip the redo/undo pair.
@@ -1935,7 +2104,7 @@ the text, but put the text in the kill ring anyway. This means that
you can use the killing commands to copy text from a read-only buffer.
This is the primitive for programs to kill text (as opposed to deleting it).
-Supply two arguments, character numbers indicating the stretch of text
+Supply two arguments, character positions indicating the stretch of text
to be killed.
Any command that calls this function is a \"kill command\".
If the previous command was also a kill command,
@@ -2009,11 +2178,12 @@ visual feedback indicating the extent of the region being copied."
;; look like a C-g typed as a command.
(inhibit-quit t))
(if (pos-visible-in-window-p other-end (selected-window))
- (unless transient-mark-mode
+ (unless (and transient-mark-mode
+ (face-background 'region))
;; Swap point and mark.
(set-marker (mark-marker) (point) (current-buffer))
(goto-char other-end)
- (sit-for 1)
+ (sit-for blink-matching-delay)
;; Swap back.
(set-marker (mark-marker) other-end (current-buffer))
(goto-char opoint)
@@ -2051,7 +2221,7 @@ The argument is used for internal purposes; do not supply one."
The value should be a list of text properties to discard or t,
which means to discard all text properties."
:type '(choice (const :tag "All" t) (repeat symbol))
- :group 'editing
+ :group 'killing
:version "21.4")
(defvar yank-window-start nil)
@@ -2261,8 +2431,7 @@ With prefix arg, kill that many lines starting from the current line.
If arg is negative, kill backward. Also kill the preceding newline.
\(This is meant to make C-x z work well with negative arguments.\)
If arg is zero, kill current line but exclude the trailing newline."
- (interactive "P")
- (setq arg (prefix-numeric-value arg))
+ (interactive "p")
(if (and (> arg 0) (eobp) (save-excursion (forward-visible-line 0) (eobp)))
(signal 'end-of-buffer nil))
(if (and (< arg 0) (bobp) (save-excursion (end-of-visible-line) (bobp)))
@@ -3257,15 +3426,14 @@ Setting this variable automatically makes it local to the current buffer.")
;; (Actually some major modes use a different auto-fill function,
;; but this one is the default one.)
(defun do-auto-fill ()
- (let (fc justify bol give-up
+ (let (fc justify give-up
(fill-prefix fill-prefix))
(if (or (not (setq justify (current-justification)))
(null (setq fc (current-fill-column)))
(and (eq justify 'left)
(<= (current-column) fc))
- (save-excursion (beginning-of-line)
- (setq bol (point))
- (and auto-fill-inhibit-regexp
+ (and auto-fill-inhibit-regexp
+ (save-excursion (beginning-of-line)
(looking-at auto-fill-inhibit-regexp))))
nil ;; Auto-filling not required
(if (memq justify '(full center right))
@@ -3288,16 +3456,15 @@ Setting this variable automatically makes it local to the current buffer.")
;; Determine where to split the line.
(let* (after-prefix
(fill-point
- (let ((opoint (point)))
- (save-excursion
- (beginning-of-line)
- (setq after-prefix (point))
- (and fill-prefix
- (looking-at (regexp-quote fill-prefix))
- (setq after-prefix (match-end 0)))
- (move-to-column (1+ fc))
- (fill-move-to-break-point after-prefix)
- (point)))))
+ (save-excursion
+ (beginning-of-line)
+ (setq after-prefix (point))
+ (and fill-prefix
+ (looking-at (regexp-quote fill-prefix))
+ (setq after-prefix (match-end 0)))
+ (move-to-column (1+ fc))
+ (fill-move-to-break-point after-prefix)
+ (point))))
;; See whether the place we found is any good.
(if (save-excursion
@@ -4116,27 +4283,29 @@ The completion list buffer is available as the value of `standard-output'.")
;; This function goes in completion-setup-hook, so that it is called
;; after the text of the completion list buffer is written.
-(defface completion-emphasis
+(defface completions-first-difference
'((t (:inherit bold)))
"Face put on the first uncommon character in completions in *Completions* buffer."
:group 'completion)
-(defface completion-de-emphasis
+(defface completions-common-part
'((t (:inherit default)))
- "Face put on the common prefix substring in completions in *Completions* buffer."
+ "Face put on the common prefix substring in completions in *Completions* buffer.
+The idea of `completions-common-part' is that you can use it to
+make the common parts less visible than normal, so that the rest
+of the differing parts is, by contrast, slightly highlighted."
:group 'completion)
(defun completion-setup-function ()
- (save-excursion
- (let ((mainbuf (current-buffer))
- (mbuf-contents (minibuffer-contents)))
- ;; When reading a file name in the minibuffer,
- ;; set default-directory in the minibuffer
- ;; so it will get copied into the completion list buffer.
- (if minibuffer-completing-file-name
- (with-current-buffer mainbuf
- (setq default-directory (file-name-directory mbuf-contents))))
- (set-buffer standard-output)
+ (let ((mainbuf (current-buffer))
+ (mbuf-contents (minibuffer-contents)))
+ ;; When reading a file name in the minibuffer,
+ ;; set default-directory in the minibuffer
+ ;; so it will get copied into the completion list buffer.
+ (if minibuffer-completing-file-name
+ (with-current-buffer mainbuf
+ (setq default-directory (file-name-directory mbuf-contents))))
+ (with-current-buffer standard-output
(completion-list-mode)
(make-local-variable 'completion-reference-buffer)
(setq completion-reference-buffer mainbuf)
@@ -4145,35 +4314,36 @@ The completion list buffer is available as the value of `standard-output'.")
;; use the number of chars before the start of the
;; last file name component.
(setq completion-base-size
- (save-excursion
- (set-buffer mainbuf)
- (goto-char (point-max))
- (skip-chars-backward "^/")
- (- (point) (minibuffer-prompt-end))))
+ (with-current-buffer mainbuf
+ (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward "^/")
+ (- (point) (minibuffer-prompt-end)))))
;; Otherwise, in minibuffer, the whole input is being completed.
- (save-match-data
- (if (minibufferp mainbuf)
- (setq completion-base-size 0))))
- ;; Put emphasis and de-emphasis faces on completions.
+ (if (minibufferp mainbuf)
+ (setq completion-base-size 0)))
+ ;; Put faces on first uncommon characters and common parts.
(when completion-base-size
- (let ((common-string-length (length
- (substring mbuf-contents
- completion-base-size)))
- (element-start (next-single-property-change
- (point-min)
- 'mouse-face))
- element-common-end)
- (while element-start
- (setq element-common-end (+ element-start common-string-length))
+ (let* ((common-string-length
+ (- (length mbuf-contents) completion-base-size))
+ (element-start (next-single-property-change
+ (point-min)
+ 'mouse-face))
+ (element-common-end
+ (+ (or element-start nil) common-string-length))
+ (maxp (point-max)))
+ (while (and element-start (< element-common-end maxp))
(when (and (get-char-property element-start 'mouse-face)
(get-char-property element-common-end 'mouse-face))
(put-text-property element-start element-common-end
- 'font-lock-face 'completion-de-emphasis)
+ 'font-lock-face 'completions-common-part)
(put-text-property element-common-end (1+ element-common-end)
- 'font-lock-face 'completion-emphasis))
- (setq element-start (next-single-property-change
+ 'font-lock-face 'completions-first-difference))
+ (setq element-start (next-single-property-change
element-start
- 'mouse-face)))))
+ 'mouse-face))
+ (if element-start
+ (setq element-common-end (+ element-start common-string-length))))))
;; Insert help string.
(goto-char (point-min))
(if (display-mouse-p)
@@ -4624,5 +4794,5 @@ works by saving the value of `buffer-invisibility-spec' and setting it to nil."
(provide 'simple)
-;;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
+;; arch-tag: 24af67c0-2a49-44f6-b3b1-312d8b570dfd
;;; simple.el ends here
diff --git a/lisp/smerge-mode.el b/lisp/smerge-mode.el
index bd4d8d04a6f..35903dcf749 100644
--- a/lisp/smerge-mode.el
+++ b/lisp/smerge-mode.el
@@ -65,7 +65,7 @@
(defcustom smerge-diff-switches
(append '("-d" "-b")
(if (listp diff-switches) diff-switches (list diff-switches)))
- "*A list of strings specifying switches to be be passed to diff.
+ "*A list of strings specifying switches to be passed to diff.
Used in `smerge-diff-base-mine' and related functions."
:group 'smerge
:type '(repeat string))
@@ -324,7 +324,7 @@ according to `smerge-match-conflict'.")
;; Out of range
(popup-menu smerge-mode-menu)
;; Install overlay.
- (setq o (make-overlay (match-beginning i) (match-end i)))
+ (setq o (make-overlay (match-beginning i) (match-end i)))
(unwind-protect
(progn
(overlay-put o 'face 'highlight)
@@ -477,6 +477,13 @@ An error is raised if not inside a conflict."
;; handle the various conflict styles
(cond
+ ((save-excursion
+ (goto-char mine-start)
+ (re-search-forward smerge-begin-re end t))
+ ;; There's a nested conflict and we're after the the beginning
+ ;; of the outer one but before the beginning of the inner one.
+ (error "There is a nested conflict"))
+
((re-search-backward smerge-base-re start t)
;; a 3-parts conflict
(set (make-local-variable 'smerge-conflict-style) 'diff3-A)
@@ -505,7 +512,7 @@ An error is raised if not inside a conflict."
(unwind-protect
(add-text-properties start end smerge-text-properties)
(restore-buffer-modified-p m)))
-
+
(store-match-data (list start end
mine-start mine-end
base-start base-end
@@ -521,9 +528,11 @@ The submatches are the same as in `smerge-match-conflict'.
Returns non-nil if a match is found between the point and LIMIT.
The point is moved to the end of the conflict."
(when (re-search-forward smerge-begin-re limit t)
- (ignore-errors
- (smerge-match-conflict)
- (goto-char (match-end 0)))))
+ (condition-case err
+ (progn
+ (smerge-match-conflict)
+ (goto-char (match-end 0)))
+ (error (smerge-find-conflict limit)))))
(defun smerge-diff (n1 n2)
(smerge-match-conflict)
@@ -673,5 +682,5 @@ buffer names."
(provide 'smerge-mode)
-;;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
+;; arch-tag: 605c8d1e-e43d-4943-a6f3-1bcc4333e690
;;; smerge-mode.el ends here
diff --git a/lisp/startup.el b/lisp/startup.el
index b3066bffbab..b06b3094769 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -1,6 +1,6 @@
;;; startup.el --- process Emacs shell arguments
-;; Copyright (C) 1985, 86, 92, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002
+;; Copyright (C) 1985, 86, 92, 94, 95, 96, 97, 98, 99, 2000, 01, 02, 2004
;; Free Software Foundation, Inc.
;; Maintainer: FSF
@@ -575,7 +575,7 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'."
(if (eq system-type 'ms-dos)
(getenv "TMPDIR")))
(setq auto-save-file-name-transforms
- (list (list "\\`/[^/]*:\\(.+/\\)*\\(.*\\)"
+ (list (list (car (car auto-save-file-name-transforms))
;; Don't put "\\2" inside expand-file-name, since
;; it will be transformed to "/2" on DOS/Windows.
(concat temporary-file-directory "\\2") t)))
diff --git a/lisp/subr.el b/lisp/subr.el
index 39a9caa3106..5382e5c42f7 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -90,7 +90,9 @@ DOCSTRING is an optional documentation string.
But documentation strings are usually not useful in nameless functions.
INTERACTIVE should be a call to the function `interactive', which see.
It may also be omitted.
-BODY should be a list of Lisp expressions."
+BODY should be a list of Lisp expressions.
+
+\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
@@ -161,7 +163,7 @@ the return value (nil if RESULT is omitted).
(defmacro declare (&rest specs)
"Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
-`defmacro' form. \(See Info anchor `(elisp)Definition of declare'."
+`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
nil)
(defsubst caar (x)
@@ -180,34 +182,34 @@ Treated as a declaration when used at the right place in a
"Return the cdr of the cdr of X."
(cdr (cdr x)))
-(defun last (x &optional n)
- "Return the last link of the list X. Its car is the last element.
-If X is nil, return nil.
-If N is non-nil, return the Nth-to-last link of X.
-If N is bigger than the length of X, return X."
+(defun last (list &optional n)
+ "Return the last link of LIST. Its car is the last element.
+If LIST is nil, return nil.
+If N is non-nil, return the Nth-to-last link of LIST.
+If N is bigger than the length of LIST, return LIST."
(if n
- (let ((m 0) (p x))
+ (let ((m 0) (p list))
(while (consp p)
(setq m (1+ m) p (cdr p)))
(if (<= n 0) p
- (if (< n m) (nthcdr (- m n) x) x)))
- (while (consp (cdr x))
- (setq x (cdr x)))
- x))
+ (if (< n m) (nthcdr (- m n) list) list)))
+ (while (consp (cdr list))
+ (setq list (cdr list)))
+ list))
-(defun butlast (x &optional n)
+(defun butlast (list &optional n)
"Returns a copy of LIST with the last N elements removed."
- (if (and n (<= n 0)) x
- (nbutlast (copy-sequence x) n)))
+ (if (and n (<= n 0)) list
+ (nbutlast (copy-sequence list) n)))
-(defun nbutlast (x &optional n)
+(defun nbutlast (list &optional n)
"Modifies LIST to remove the last N elements."
- (let ((m (length x)))
+ (let ((m (length list)))
(or n (setq n 1))
(and (< n m)
(progn
- (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
- x))))
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
+ list))))
(defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST.
@@ -627,7 +629,11 @@ The normal global definition of the character C-x indirects to this keymap.")
(defsubst eventp (obj)
"True if the argument is an event object."
- (or (integerp obj)
+ (or (and (integerp obj)
+ ;; Filter out integers too large to be events.
+ ;; M is the biggest modifier.
+ (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
+ (characterp (event-basic-type obj)))
(and (symbolp obj)
(get obj 'event-symbol-elements))
(and (consp obj)
@@ -644,14 +650,16 @@ and `down'."
(setq type (car type)))
(if (symbolp type)
(cdr (get type 'event-symbol-elements))
- (let ((list nil))
- (or (zerop (logand type ?\M-\^@))
+ (let ((list nil)
+ (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@
+ ?\H-\^@ ?\s-\^@ ?\A-\^@)))))
+ (if (not (zerop (logand type ?\M-\^@)))
(setq list (cons 'meta list)))
- (or (and (zerop (logand type ?\C-\^@))
- (>= (logand type 127) 32))
+ (if (or (not (zerop (logand type ?\C-\^@)))
+ (< char 32))
(setq list (cons 'control list)))
- (or (and (zerop (logand type ?\S-\^@))
- (= (logand type 255) (downcase (logand type 255))))
+ (if (or (not (zerop (logand type ?\S-\^@)))
+ (/= char (downcase char)))
(setq list (cons 'shift list)))
(or (zerop (logand type ?\H-\^@))
(setq list (cons 'hyper list)))
@@ -843,9 +851,11 @@ and `event-end' functions."
(make-obsolete 'dot-min 'point-min "before 19.15")
(make-obsolete 'dot-marker 'point-marker "before 19.15")
(make-obsolete 'buffer-flush-undo 'buffer-disable-undo "before 19.15")
-(make-obsolete 'baud-rate "use the baud-rate variable instead." "before 19.15")
+(make-obsolete 'baud-rate "use the `baud-rate' variable instead." "before 19.15")
(make-obsolete 'compiled-function-p 'byte-code-function-p "before 19.15")
(make-obsolete 'define-function 'defalias "20.1")
+(make-obsolete 'focus-frame "it does nothing." "19.32")
+(make-obsolete 'unfocus-frame "it does nothing." "19.32")
(defun insert-string (&rest args)
"Mocklisp-compatibility insert function.
@@ -862,8 +872,8 @@ is converted into a string by expressing it in decimal."
"Return the value of the `baud-rate' variable."
baud-rate)
-(defalias 'focus-frame 'ignore)
-(defalias 'unfocus-frame 'ignore)
+(defalias 'focus-frame 'ignore "")
+(defalias 'unfocus-frame 'ignore "")
;;;; Obsolescence declarations for variables.
@@ -1112,16 +1122,17 @@ FILE should be the name of a library, with no directory name."
"Open a TCP connection for a service to a host.
Returns a subprocess-object to represent the connection.
Input and output work as for subprocesses; `delete-process' closes it.
+
Args are NAME BUFFER HOST SERVICE.
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
- with any buffer
-Third arg is name of the host to connect to, or its IP address.
-Fourth arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to."
+ with any buffer.
+HOST is name of the host to connect to, or its IP address.
+SERVICE is name of the service desired, or an integer specifying
+ a port number to connect to."
(make-network-process :name name :buffer buffer
:host host :service service))
@@ -1130,14 +1141,14 @@ specifying a port number to connect to."
It returns nil if non-blocking connects are not supported; otherwise,
it returns a subprocess-object to represent the connection.
-This function is similar to `open-network-stream', except that this
-function returns before the connection is established. When the
-connection is completed, the sentinel function will be called with
-second arg matching `open' (if successful) or `failed' (on error).
+This function is similar to `open-network-stream', except that it
+returns before the connection is established. When the connection
+is completed, the sentinel function will be called with second arg
+matching `open' (if successful) or `failed' (on error).
Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
+Optional args SENTINEL and FILTER specify the sentinel and filter
functions to be used for this network stream."
(if (featurep 'make-network-process '(:nowait t))
(make-network-process :name name :buffer buffer :nowait t
@@ -1155,17 +1166,17 @@ is called for the new process.
Args are NAME BUFFER SERVICE SENTINEL FILTER.
NAME is name for the server process. Client processes are named by
-appending the ip-address and port number of the client to NAME.
-BUFFER is the buffer (or buffer-name) to associate with the server
-process. Client processes will not get a buffer if a process filter
-is specified or BUFFER is nil; otherwise, a new buffer is created for
-the client process. The name is similar to the process name.
+ appending the ip-address and port number of the client to NAME.
+BUFFER is the buffer (or buffer name) to associate with the server
+ process. Client processes will not get a buffer if a process filter
+ is specified or BUFFER is nil; otherwise, a new buffer is created for
+ the client process. The name is similar to the process name.
Third arg SERVICE is name of the service desired, or an integer
-specifying a port number to connect to. It may also be t to selected
-an unused port number for the server.
-Optional args, SENTINEL and FILTER specifies the sentinel and filter
-functions to be used for the client processes; the server process
-does not use these function."
+ specifying a port number to connect to. It may also be t to select
+ an unused port number for the server.
+Optional args SENTINEL and FILTER specify the sentinel and filter
+ functions to be used for the client processes; the server process
+ does not use these function."
(if (featurep 'make-network-process '(:server t))
(make-network-process :name name :buffer buffer
:service service :server t :noquery t
@@ -1176,12 +1187,13 @@ does not use these function."
;; compatibility
+(make-obsolete 'process-kill-without-query
+ "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'."
+ "21.5")
(defun process-kill-without-query (process &optional flag)
"Say no query needed if PROCESS is running when Emacs is exited.
Optional second argument if non-nil says to require a query.
-Value is t if a query was formerly required.
-New code should not use this function; use `process-query-on-exit-flag'
-or `set-process-query-on-exit-flag' instead."
+Value is t if a query was formerly required."
(let ((old (process-query-on-exit-flag process)))
(set-process-query-on-exit-flag process nil)
old))
@@ -1274,7 +1286,7 @@ any other non-digit terminates the character code and is then used as input."))
(defun read-passwd (prompt &optional confirm default)
"Read a password, prompting with PROMPT. Echo `.' for each character typed.
End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
-Optional argument CONFIRM, if non-nil, then read it twice to make sure.
+If optional CONFIRM is non-nil, read password twice to make sure.
Optional DEFAULT is a default password to use instead of empty input."
(if confirm
(let (success)
@@ -1323,13 +1335,16 @@ Optional DEFAULT is a default password to use instead of empty input."
(let ((n nil))
(when default
(setq prompt
- (if (string-match "\\(\\):[^:]*" prompt)
- (replace-match (format " [%s]" default) t t prompt 1)
- (concat prompt (format " [%s] " default)))))
+ (if (string-match "\\(\\):[ \t]*\\'" prompt)
+ (replace-match (format " (default %s)" default) t t prompt 1)
+ (replace-regexp-in-string "[ \t]*\\'"
+ (format " (default %s) " default)
+ prompt t t))))
(while
(progn
(let ((str (read-from-minibuffer prompt nil nil nil nil
- (number-to-string default))))
+ (and default
+ (number-to-string default)))))
(setq n (cond
((zerop (length str)) default)
((stringp str) (read str)))))
@@ -1454,9 +1469,11 @@ menu bar menus and the frame title."
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
-Display remains until next character is typed.
-If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
-otherwise it is then available as input (as a command if nothing else).
+Display remains until next event is input.
+Optional third arg EXIT-CHAR can be a character, event or event
+description list. EXIT-CHAR defaults to SPC. If the input is
+EXIT-CHAR it is swallowed; otherwise it is then available as
+input (as a command if nothing else).
Display MESSAGE (optional fourth arg) in the echo area.
If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(or exit-char (setq exit-char ?\ ))
@@ -1486,9 +1503,23 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(recenter 0))))
(message (or message "Type %s to continue editing.")
(single-key-description exit-char))
- (let ((char (read-event)))
- (or (eq char exit-char)
- (setq unread-command-events (list char)))))
+ (let (char)
+ (if (integerp exit-char)
+ (condition-case nil
+ (progn
+ (setq char (read-char))
+ (or (eq char exit-char)
+ (setq unread-command-events (list char))))
+ (error
+ ;; `exit-char' is a character, hence it differs
+ ;; from char, which is an event.
+ (setq unread-command-events (list char))))
+ ;; `exit-char' can be an event, or an event description
+ ;; list.
+ (setq char (read-event))
+ (or (eq char exit-char)
+ (eq char (event-convert-list exit-char))
+ (setq unread-command-events (list char))))))
(if insert-end
(save-excursion
(delete-region pos insert-end)))
@@ -1509,9 +1540,12 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(overlay-put o1 (pop props) (pop props)))
o1))
-(defun remove-overlays (beg end name val)
+(defun remove-overlays (&optional beg end name val)
"Clear BEG and END of overlays whose property NAME has value VAL.
-Overlays might be moved and or split."
+Overlays might be moved and/or split.
+BEG and END default respectively to the beginning and end of buffer."
+ (unless beg (setq beg (point-min)))
+ (unless end (setq end (point-max)))
(if (< end beg)
(setq beg (prog1 end (setq end beg))))
(save-excursion
@@ -1671,26 +1705,27 @@ If UNDO is present and non-nil, it is a function that will be called
(if (nth 4 handler) ;; COMMAND
(setq this-command (nth 4 handler)))))
-(defun insert-buffer-substring-no-properties (buf &optional start end)
- "Insert before point a substring of buffer BUFFER, without text properties.
+(defun insert-buffer-substring-no-properties (buffer &optional start end)
+ "Insert before point a substring of BUFFER, without text properties.
BUFFER may be a buffer or a buffer name.
-Arguments START and END are character numbers specifying the substring.
-They default to the beginning and the end of BUFFER."
+Arguments START and END are character positions specifying the substring.
+They default to the values of (point-min) and (point-max) in BUFFER."
(let ((opoint (point)))
- (insert-buffer-substring buf start end)
+ (insert-buffer-substring buffer start end)
(let ((inhibit-read-only t))
(set-text-properties opoint (point) nil))))
-(defun insert-buffer-substring-as-yank (buf &optional start end)
- "Insert before point a part of buffer BUFFER, stripping some text properties.
-BUFFER may be a buffer or a buffer name. Arguments START and END are
-character numbers specifying the substring. They default to the
-beginning and the end of BUFFER. Strip text properties from the
-inserted text according to `yank-excluded-properties'."
+(defun insert-buffer-substring-as-yank (buffer &optional start end)
+ "Insert before point a part of BUFFER, stripping some text properties.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are character positions specifying the substring.
+They default to the values of (point-min) and (point-max) in BUFFER.
+Strip text properties from the inserted text according to
+`yank-excluded-properties'."
;; Since the buffer text should not normally have yank-handler properties,
;; there is no need to handle them here.
(let ((opoint (point)))
- (insert-buffer-substring buf start end)
+ (insert-buffer-substring buffer start end)
(remove-yank-excluded-properties opoint (point))))
@@ -1698,16 +1733,17 @@ inserted text according to `yank-excluded-properties'."
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
-Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
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
with any buffer
-Third arg is command name, the name of a shell command.
+COMMAND is the name of a shell command.
Remaining arguments are the arguments for the command.
-Wildcards and redirection are handled as usual in the shell."
+Wildcards and redirection are handled as usual in the shell.
+
+\(fn NAME BUFFER COMMAND &rest COMMAND-ARGS)"
(cond
((eq system-type 'vax-vms)
(apply 'start-process name buffer args))
@@ -1766,6 +1802,9 @@ See also `with-temp-buffer'."
(declare (indent 1) (debug t))
;; Most of this code is a copy of save-selected-window.
`(let ((save-selected-window-window (selected-window))
+ ;; It is necessary to save all of these, because calling
+ ;; select-window changes frame-selected-window for whatever
+ ;; frame that window is in.
(save-selected-window-alist
(mapcar (lambda (frame) (list frame (frame-selected-window frame)))
(frame-list))))
@@ -1777,7 +1816,6 @@ See also `with-temp-buffer'."
(window-live-p (cadr elt))
(set-frame-selected-window (car elt) (cadr elt))))
(if (window-live-p save-selected-window-window)
- ;; This is where the code differs from save-selected-window.
(select-window save-selected-window-window 'norecord)))))
(defmacro with-temp-file (file &rest body)
@@ -2051,7 +2089,7 @@ which separates, but is not part of, the substrings. If nil it defaults to
`split-string-default-separators', normally \"[ \\f\\t\\n\\r\\v]+\", and
OMIT-NULLS is forced to t.
-If OMIT-NULLs is t, zero-length substrings are omitted from the list \(so
+If OMIT-NULLS is t, zero-length substrings are omitted from the list \(so
that for the default value of SEPARATORS leading and trailing whitespace
are effectively trimmed). If nil, all zero-length substrings are retained,
which correctly parses CSV format, for example.
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index fc178316045..b2f2269c558 100644
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -1,6 +1,6 @@
;;; w32-win.el --- parse switches controlling interface with W32 window system
-;; Copyright (C) 1993, 1994, 2003 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 2003, 2004 Free Software Foundation, Inc.
;; Author: Kevin Gallo
;; Keywords: terminals
@@ -76,6 +76,9 @@
(require 'faces)
(require 'select)
(require 'menu-bar)
+(require 'x-dnd)
+(require 'code-pages)
+
;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
(if (fboundp 'new-fontset)
(require 'fontset))
@@ -105,7 +108,10 @@ Switch to a buffer editing the last file dropped."
(y (cdr coords)))
(if (and (> x 0) (> y 0))
(set-frame-selected-window nil window))
- (mapcar 'find-file (car (cdr (cdr event)))))
+ (mapcar (lambda (file-name)
+ (x-dnd-handle-one-url window 'private
+ (concat "file:" file-name)))
+ (car (cdr (cdr event)))))
(raise-frame)))
(defun w32-drag-n-drop-other-frame (event)
@@ -1255,5 +1261,13 @@ font dialog to get the matching FONTS. Otherwise use a pop-up menu
(if (null font)
(error "Font not found")))))
+;;; Set default known names for image libraries
+(setq image-library-alist
+ '((xpm "libXpm-nox4.dll" "libxpm.dll")
+ (png "libpng13d.dll" "libpng13.dll" "libpng12d.dll" "libpng12.dll" "libpng.dll")
+ (jpeg "jpeg62.dll" "libjpeg.dll" "jpeg-62.dll" "jpeg.dll")
+ (tiff "libtiff3.dll" "libtiff.dll")
+ (gif "libungif.dll")))
+
;;; arch-tag: 69fb1701-28c2-4890-b351-3d1fe4b4f166
;;; w32-win.el ends here
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index 074524622c9..ed5bce00f44 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -2438,7 +2438,10 @@ order until succeed.")
(defun x-clipboard-yank ()
"Insert the clipboard contents, or the last stretch of killed text."
(interactive)
- (let ((clipboard-text (x-get-selection 'CLIPBOARD))
+ (let ((clipboard-text
+ (condition-case nil
+ (x-get-selection 'CLIPBOARD)
+ (error nil)))
(x-select-enable-clipboard t))
(if (and clipboard-text (> (length clipboard-text) 0))
(kill-new clipboard-text))
diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el
index e4f143c3b87..9535d39b1d1 100644
--- a/lisp/textmodes/artist.el
+++ b/lisp/textmodes/artist.el
@@ -1,6 +1,6 @@
;;; artist.el --- draw ascii graphics with your mouse
-;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc.
;; Author: Tomas Abrahamsson <tab@lysator.liu.se>
;; Maintainer: Tomas Abrahamsson <tab@lysator.liu.se>
@@ -1698,19 +1698,14 @@ info-variant-part."
(t (cons (car l) (artist-butlast (cdr l))))))
-(defun artist-last (seq &optional n)
- "Return the last link in the list SEQ.
+(defun artist-last (l &optional n)
+ "Return the last link in the list L.
With optional argument N, returns Nth-to-last link (default 1)."
- (if (not n)
- (setq n 1))
- (let ((len (length seq)))
- (elt seq (- len n))))
+ (nth (- (length l) (or n 1)) l))
(defun artist-remove-nulls (l)
"Remove nils in list L."
- (cond ((null l) nil)
- ((null (car l)) (artist-remove-nulls (cdr l)))
- (t (cons (car l) (artist-remove-nulls (cdr l))))))
+ (remq nil l))
(defun artist-uniq (l)
"Remove consecutive duplicates in list L. Comparison is done with `equal'."
@@ -3368,8 +3363,8 @@ The POINT-LIST is expected to cover the first quadrant."
(append right-half left-half)))
-(defun artist-draw-ellipse-general (x y x-radius y-radius)
- "Draw an ellipse with center at X, Y and X-RADIUS and Y-RADIUS.
+(defun artist-draw-ellipse-general (x1 y1 x-radius y-radius)
+ "Draw an ellipse with center at X1, Y1 and X-RADIUS and Y-RADIUS.
Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO).
@@ -3379,15 +3374,15 @@ SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO].
POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR].
FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE].
-Ellipses with zero y-radius are not drawn correctly."
+Ellipses with zero Y-RADIUS are not drawn correctly."
(let* ((point-list (artist-ellipse-generate-quadrant x-radius y-radius))
(fill-info (artist-ellipse-compute-fill-info point-list))
(shape-info (make-vector 2 0)))
(setq point-list (artist-calculate-new-chars point-list))
(setq point-list (artist-ellipse-mirror-quadrant point-list))
- (setq point-list (artist-ellipse-point-list-add-center x y point-list))
- (setq fill-info (artist-ellipse-fill-info-add-center x y fill-info))
+ (setq point-list (artist-ellipse-point-list-add-center x1 y1 point-list))
+ (setq fill-info (artist-ellipse-fill-info-add-center x1 y1 fill-info))
;; Draw the ellipse
(setq point-list
@@ -3404,12 +3399,12 @@ Ellipses with zero y-radius are not drawn correctly."
(aset shape-info 0 point-list)
(aset shape-info 1 fill-info)
- (artist-make-2point-object (artist-make-endpoint x y)
+ (artist-make-2point-object (artist-make-endpoint x1 y1)
(artist-make-endpoint x-radius y-radius)
shape-info)))
-(defun artist-draw-ellipse-with-0-height (x y x-radius y-radius)
- "Draw an ellipse with center at X, Y and X-RADIUS and Y-RADIUS.
+(defun artist-draw-ellipse-with-0-height (x1 y1 x-radius y-radius)
+ "Draw an ellipse with center at X1, Y1 and X-RADIUS and Y-RADIUS.
Output is an ellipse, which is a list (END-POINT-1 END-POINT-2 SHAPE-INFO).
@@ -3419,10 +3414,10 @@ SHAPE-INFO is a two-element vector on the form [POINT-LIST FILL-INFO].
POINT-LIST is a list of vectors on the form [X Y SAVED-CHAR NEW-CHAR].
FILL-INFO is a list of vectors on the form [X Y ELLIPSE-WIDTH-ON-THIS-LINE].
-The Y-RADIUS must be 0, but the X-RADUIS must not be 0."
+The Y-RADIUS must be 0, but the X-RADIUS must not be 0."
(let ((point-list nil)
(width (max (- (abs (* 2 x-radius)) 1)))
- (left-edge (1+ (- x (abs x-radius))))
+ (left-edge (1+ (- x1 (abs x-radius))))
(line-char (if artist-line-char-set artist-line-char ?-))
(i 0)
(point-list nil)
@@ -3430,7 +3425,7 @@ The Y-RADIUS must be 0, but the X-RADUIS must not be 0."
(shape-info (make-vector 2 0)))
(while (< i width)
(let* ((line-x (+ left-edge i))
- (line-y y)
+ (line-y y1)
(new-coord (artist-new-coord line-x line-y)))
(artist-coord-add-saved-char new-coord
(artist-get-char-at-xy line-x line-y))
@@ -3440,7 +3435,7 @@ The Y-RADIUS must be 0, but the X-RADUIS must not be 0."
(setq i (1+ i))))
(aset shape-info 0 point-list)
(aset shape-info 1 fill-info)
- (artist-make-2point-object (artist-make-endpoint x y)
+ (artist-make-2point-object (artist-make-endpoint x1 y1)
(artist-make-endpoint x-radius y-radius)
shape-info)))
@@ -3954,7 +3949,7 @@ The 2-point shape SHAPE is drawn from X1, Y1 to X2, Y2."
(defun artist-draw-region-trim-line-endings (min-y max-y)
"Trim lines in current draw-region from MIN-Y to MAX-Y.
-Trimming here means removing white space at end of a line"
+Trimming here means removing white space at end of a line."
;; Safetyc check: switch min-y and max-y if if max-y is smaller
(if (< max-y min-y)
(let ((tmp min-y))
@@ -4286,7 +4281,7 @@ If optional argument THIS-IS-LAST-POINT is non-nil, this point is the last."
(defun artist-key-set-point-common (arg)
"Common routine for setting point in current shape.
-With ARG set to t, set the last point."
+With non-nil ARG, set the last point."
(let ((draw-how (artist-go-get-draw-how-from-symbol artist-curr-go))
(col (artist-current-column))
(row (artist-current-line))
@@ -4793,7 +4788,7 @@ If optional argument STATE is positive, turn borders on."
(defun artist-mouse-choose-operation (ev op)
- "Choose operation for evenvt EV and operation OP."
+ "Choose operation for event EV and operation OP."
(interactive
(progn
(select-window (posn-window (event-start last-input-event)))
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el
index 82b15cf4eb5..15348205c51 100644
--- a/lisp/textmodes/bibtex.el
+++ b/lisp/textmodes/bibtex.el
@@ -1,6 +1,7 @@
;;; bibtex.el --- BibTeX mode for GNU Emacs
-;; Copyright (C) 1992,94,95,96,97,98,1999,2003 Free Software Foundation, Inc.
+;; Copyright (C) 1992,94,95,96,97,98,1999,2003,2004
+;; Free Software Foundation, Inc.
;; Author: Stefan Schoef <schoef@offis.uni-oldenburg.de>
;; Bengt Martensson <bengt@mathematik.uni-Bremen.de>
@@ -811,6 +812,7 @@ If non-nil, the column for the equal sign is the value of
(define-key km "\C-c\M-y" 'bibtex-yank-pop)
(define-key km "\C-c\C-d" 'bibtex-empty-field)
(define-key km "\C-c\C-f" 'bibtex-make-field)
+ (define-key km "\C-c\C-u" 'bibtex-entry-update)
(define-key km "\C-c$" 'bibtex-ispell-abstract)
(define-key km "\M-\C-a" 'bibtex-beginning-of-entry)
(define-key km "\M-\C-e" 'bibtex-end-of-entry)
@@ -1122,44 +1124,6 @@ function `bibtex-parse-field-name'.")
'(bibtex-mode "@\\S(*\\s(" "\\s)" nil bibtex-hs-forward-sexp nil))
-(defconst bibtex-braced-string-syntax-table
- (let ((st (make-syntax-table)))
- (modify-syntax-entry ?\{ "(}" st)
- (modify-syntax-entry ?\} "){" st)
- (modify-syntax-entry ?\[ "." st)
- (modify-syntax-entry ?\] "." st)
- (modify-syntax-entry ?\( "." st)
- (modify-syntax-entry ?\) "." st)
- (modify-syntax-entry ?\\ "." st)
- (modify-syntax-entry ?\" "." st)
- st)
- "Syntax-table to parse matched braces.")
-
-(defconst bibtex-quoted-string-syntax-table
- (let ((st (make-syntax-table)))
- (modify-syntax-entry ?\\ "\\" st)
- (modify-syntax-entry ?\" "\"" st)
- st)
- "Syntax-table to parse matched quotes.")
-
-(defun bibtex-parse-field-string ()
- "Parse a field string enclosed by braces or quotes.
-If a syntactically correct string is found, a pair containing the start and
-end position of the field string is returned, nil otherwise."
- (let ((end-point
- (or (and (eq (following-char) ?\")
- (save-excursion
- (with-syntax-table bibtex-quoted-string-syntax-table
- (forward-sexp 1))
- (point)))
- (and (eq (following-char) ?\{)
- (save-excursion
- (with-syntax-table bibtex-braced-string-syntax-table
- (forward-sexp 1))
- (point))))))
- (if end-point
- (cons (point) end-point))))
-
(defun bibtex-parse-association (parse-lhs parse-rhs)
"Parse a string of the format <left-hand-side = right-hand-side>.
The functions PARSE-LHS and PARSE-RHS are used to parse the corresponding
@@ -1199,6 +1163,44 @@ BibTeX field as necessary."
;; Now try again.
(bibtex-parse-field-name))))
+(defconst bibtex-braced-string-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\{ "(}" st)
+ (modify-syntax-entry ?\} "){" st)
+ (modify-syntax-entry ?\[ "." st)
+ (modify-syntax-entry ?\] "." st)
+ (modify-syntax-entry ?\( "." st)
+ (modify-syntax-entry ?\) "." st)
+ (modify-syntax-entry ?\\ "." st)
+ (modify-syntax-entry ?\" "." st)
+ st)
+ "Syntax-table to parse matched braces.")
+
+(defconst bibtex-quoted-string-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\\ "\\" st)
+ (modify-syntax-entry ?\" "\"" st)
+ st)
+ "Syntax-table to parse matched quotes.")
+
+(defun bibtex-parse-field-string ()
+ "Parse a field string enclosed by braces or quotes.
+If a syntactically correct string is found, a pair containing the start and
+end position of the field string is returned, nil otherwise."
+ (let ((end-point
+ (or (and (eq (following-char) ?\")
+ (save-excursion
+ (with-syntax-table bibtex-quoted-string-syntax-table
+ (forward-sexp 1))
+ (point)))
+ (and (eq (following-char) ?\{)
+ (save-excursion
+ (with-syntax-table bibtex-braced-string-syntax-table
+ (forward-sexp 1))
+ (point))))))
+ (if end-point
+ (cons (point) end-point))))
+
(defun bibtex-parse-field-text ()
"Parse the text part of a BibTeX field.
The text part is either a string, or an empty string, or a constant followed
@@ -1410,7 +1412,7 @@ delimiters if present."
(let ((content (buffer-substring-no-properties (nth 0 (cdr bounds))
(nth 1 (cdr bounds)))))
(if (and remove-delim
- (string-match "\\`{\\(.*\\)}\\'" content))
+ (string-match "\\`[{\"]\\(.*\\)[}\"]\\'" content))
(substring content (match-beginning 1) (match-end 1))
content)))
@@ -1455,16 +1457,6 @@ The value is actually the tail of LIST whose car matches STRING."
(setq list (cdr list)))
list))
-(defun bibtex-assoc-of-regexp (string alist)
- "Return non-nil if STRING is exactly matched by the car of an
-element of ALIST (case ignored). The value is actually the element
-of LIST whose car matches STRING."
- (let ((case-fold-search t))
- (while (and alist
- (not (string-match (concat "\\`\\(?:" (caar alist) "\\)\\'") string)))
- (setq alist (cdr alist)))
- (car alist)))
-
(defun bibtex-skip-to-valid-entry (&optional backward)
"Unless at beginning of a valid BibTeX entry, move point to beginning of the
next valid one. With optional argument BACKWARD non-nil, move backward to
@@ -1510,7 +1502,7 @@ FUN will not be called for @String entries."
(save-excursion
(if (or (and (not bibtex-sort-ignore-string-entries)
(string-equal "string" (downcase entry-type)))
- (assoc-ignore-case entry-type bibtex-entry-field-alist))
+ (assoc-string entry-type bibtex-entry-field-alist t))
(funcall fun key beg end)))
(goto-char end)))))
@@ -1519,8 +1511,8 @@ FUN will not be called for @String entries."
If FLAG is a string, the message is initialized (in this case a
value for INTERVAL may be given as well (if not this is set to 5)).
If FLAG is done, the message is deinitialized.
-If FLAG is absent, a message is echoed if point was incremented
-at least INTERVAL percent since last message was echoed."
+If FLAG is nil, a message is echoed if point was incremented at least
+`bibtex-progress-interval' percent since last message was echoed."
(cond ((stringp flag)
(setq bibtex-progress-lastmes flag)
(setq bibtex-progress-interval (or interval 5)
@@ -1685,11 +1677,11 @@ are defined, but only for the head part of the entry
"Try to avoid point being at end of a BibTeX field."
(end-of-line)
(skip-chars-backward " \t")
- (cond ((= (preceding-char) ?,)
- (forward-char -2)))
- (cond ((or (= (preceding-char) ?})
- (= (preceding-char) ?\"))
- (forward-char -1))))
+ (if (= (preceding-char) ?,)
+ (forward-char -2))
+ (if (or (= (preceding-char) ?})
+ (= (preceding-char) ?\"))
+ (forward-char -1)))
(defun bibtex-enclosing-field (&optional noerr)
"Search for BibTeX field enclosing point. Point moves to end of field.
@@ -1749,6 +1741,15 @@ Beginning (but not end) of entry is given by (`match-beginning' 0)."
(error "Unknown tag field: %s. Please submit a bug report"
bibtex-last-kill-command))))))
+(defun bibtex-assoc-regexp (regexp alist)
+ "Return non-nil if REGEXP matches the car of an element of ALIST.
+The value is actually the element of ALIST matched by REGEXP.
+Case is ignored if `case-fold-search' is non-nil in the current buffer."
+ (while (and alist
+ (not (string-match regexp (caar alist))))
+ (setq alist (cdr alist)))
+ (car alist))
+
(defun bibtex-format-entry ()
"Helper function for `bibtex-clean-entry'.
Formats current entry according to variable `bibtex-entry-format'."
@@ -1763,18 +1764,17 @@ Formats current entry according to variable `bibtex-entry-format'."
unify-case inherit-booktitle)
bibtex-entry-format))
crossref-key bounds alternatives-there non-empty-alternative
- entry-list req creq field-done field-list)
+ entry-list req-field-list field-done field-list)
;; identify entry type
(goto-char (point-min))
(re-search-forward bibtex-entry-type)
(let ((beg-type (1+ (match-beginning 0)))
(end-type (match-end 0)))
- (setq entry-list (assoc-ignore-case (buffer-substring-no-properties
- beg-type end-type)
- bibtex-entry-field-alist)
- req (nth 0 (nth 1 entry-list)) ; required part
- creq (nth 0 (nth 2 entry-list))) ; crossref part
+ (setq entry-list (assoc-string (buffer-substring-no-properties
+ beg-type end-type)
+ bibtex-entry-field-alist
+ t))
;; unify case of entry name
(when (memq 'unify-case format)
@@ -1791,20 +1791,32 @@ Formats current entry according to variable `bibtex-entry-format'."
;; determine if entry has crossref field and if at least
;; one alternative is non-empty
(goto-char (point-min))
- (while (setq bounds (bibtex-search-forward-field
- bibtex-field-name))
- (goto-char (bibtex-start-of-name-in-field bounds))
- (cond ((looking-at "ALT")
- (setq alternatives-there t)
- (goto-char (bibtex-start-of-text-in-field bounds))
- (if (not (looking-at bibtex-empty-field-re))
- (setq non-empty-alternative t)))
- ((and (looking-at "\\(OPT\\)?crossref\\>")
- (progn (goto-char (bibtex-start-of-text-in-field bounds))
- (not (looking-at bibtex-empty-field-re))))
- (setq crossref-key
- (bibtex-text-in-field-bounds bounds t))))
- (goto-char (bibtex-end-of-field bounds)))
+ (let* ((fields-alist (bibtex-parse-entry))
+ (case-fold-search t)
+ (field (bibtex-assoc-regexp "\\`\\(OPT\\)?crossref\\'"
+ fields-alist)))
+ (setq crossref-key (and field
+ (not (string-match bibtex-empty-field-re
+ (cdr field)))
+ (cdr field))
+ req-field-list (if crossref-key
+ (nth 0 (nth 2 entry-list)) ; crossref part
+ (nth 0 (nth 1 entry-list)))) ; required part
+
+ (dolist (rfield req-field-list)
+ (when (nth 3 rfield) ; we should have an alternative
+ (setq alternatives-there t
+ field (bibtex-assoc-regexp
+ (concat "\\`\\(ALT\\)?" (car rfield) "\\'")
+ fields-alist))
+ (if (and field
+ (not (string-match bibtex-empty-field-re
+ (cdr field))))
+ (cond ((not non-empty-alternative)
+ (setq non-empty-alternative t))
+ ((memq 'required-fields format)
+ (error "More than one non-empty alternative.")))))))
+
(if (and alternatives-there
(not non-empty-alternative)
(memq 'required-fields format))
@@ -1832,18 +1844,23 @@ Formats current entry according to variable `bibtex-entry-format'."
;; quite some redundancy compared with what we need to do
;; anyway. So for speed-up we avoid using them.
- (when (and opt-alt
- (memq 'opts-or-alts format))
- (if empty-field
- ;; Either it is an empty ALT field. Then we have checked
- ;; already that we have one non-empty alternative.
- ;; Or it is an empty OPT field that we do not miss anyway.
- ;; So we can safely delete this field.
- (progn (delete-region beg-field end-field)
- (setq deleted t))
- ;; otherwise: not empty, delete "OPT" or "ALT"
- (goto-char beg-name)
- (delete-char 3)))
+ (if (memq 'opts-or-alts format)
+ (cond ((and empty-field
+ (or opt-alt
+ (let ((field (assoc-string
+ field-name req-field-list t)))
+ (or (not field) ; OPT field
+ (nth 3 field))))) ; ALT field
+ ;; Either it is an empty ALT field. Then we have checked
+ ;; already that we have one non-empty alternative. Or it
+ ;; is an empty OPT field that we do not miss anyway.
+ ;; So we can safely delete this field.
+ (delete-region beg-field end-field)
+ (setq deleted t))
+ ;; otherwise: not empty, delete "OPT" or "ALT"
+ (opt-alt
+ (goto-char beg-name)
+ (delete-char 3))))
(unless deleted
(push field-name field-list)
@@ -1902,16 +1919,17 @@ Formats current entry according to variable `bibtex-entry-format'."
;; if empty field, complain
(if (and empty-field
(memq 'required-fields format)
- (assoc-ignore-case field-name
- (if crossref-key creq req)))
+ (assoc-string field-name req-field-list t))
(error "Mandatory field `%s' is empty" field-name))
;; unify case of field name
(if (memq 'unify-case format)
- (let ((fname (car (assoc-ignore-case
- field-name (append (nth 0 (nth 1 entry-list))
- (nth 1 (nth 1 entry-list))
- bibtex-user-optional-fields)))))
+ (let ((fname (car (assoc-string
+ field-name
+ (append (nth 0 (nth 1 entry-list))
+ (nth 1 (nth 1 entry-list))
+ bibtex-user-optional-fields)
+ t))))
(if fname
(progn
(delete-region beg-name end-name)
@@ -1925,8 +1943,8 @@ Formats current entry according to variable `bibtex-entry-format'."
;; check whether all required fields are present
(if (memq 'required-fields format)
- (let (altlist (found 0))
- (dolist (fname (if crossref-key creq req))
+ (let ((found 0) altlist)
+ (dolist (fname req-field-list)
(if (nth 3 fname)
(push (car fname) altlist))
(unless (or (member (car fname) field-list)
@@ -1940,7 +1958,7 @@ Formats current entry according to variable `bibtex-entry-format'."
(error "Alternative mandatory field `%s' is missing"
altlist))
((> found 1)
- (error "Alternative fields `%s' is defined %s times"
+ (error "Alternative fields `%s' are defined %s times"
altlist found))))))
;; update point
@@ -2051,8 +2069,8 @@ and return results as a list."
(setq titlestring (substring titlestring 0 (match-beginning 0))))))
;; gather words from titlestring into a list. Ignore
;; specific words and use only a specific amount of words.
- (let (case-fold-search titlewords titlewords-extra titleword end-match
- (counter 0))
+ (let ((counter 0)
+ case-fold-search titlewords titlewords-extra titleword end-match)
(while (and (or (not (numberp bibtex-autokey-titlewords))
(< counter (+ bibtex-autokey-titlewords
bibtex-autokey-titlewords-stretch)))
@@ -2079,10 +2097,14 @@ and return results as a list."
"Do some abbreviations on TITLEWORD.
The rules are defined in `bibtex-autokey-titleword-abbrevs'
and `bibtex-autokey-titleword-length'."
- (let ((abbrev (bibtex-assoc-of-regexp
- titleword bibtex-autokey-titleword-abbrevs)))
- (if abbrev
- (cdr abbrev)
+ (let ((case-folde-search t)
+ (alist bibtex-autokey-titleword-abbrevs))
+ (while (and alist
+ (not (string-match (concat "\\`\\(?:" (caar alist) "\\)\\'")
+ titleword)))
+ (setq alist (cdr alist)))
+ (if alist
+ (cdar alist)
(bibtex-autokey-abbrev titleword
bibtex-autokey-titleword-length))))
@@ -2239,8 +2261,8 @@ Return alist of keys if parsing was completed, `aborted' otherwise."
;; This is a crossref.
(buffer-substring-no-properties
(1+ (match-beginning 3)) (1- (match-end 3))))
- ((assoc-ignore-case (bibtex-type-in-head)
- bibtex-entry-field-alist)
+ ((assoc-string (bibtex-type-in-head)
+ bibtex-entry-field-alist t)
;; This is an entry.
(match-string-no-properties bibtex-key-in-head)))))
(if (and (stringp key)
@@ -2295,7 +2317,7 @@ Return alist of strings if parsing was completed, `aborted' otherwise."
;; user has aborted by typing a key --> return `aborted'
(throw 'userkey 'aborted))
(setq key (bibtex-reference-key-in-string bounds))
- (if (not (assoc-ignore-case key strings))
+ (if (not (assoc key strings))
(push (cons key (bibtex-text-in-string bounds t))
strings))
(goto-char (bibtex-end-of-text-in-string bounds)))
@@ -2384,6 +2406,7 @@ of a word, all strings are listed. Return completion."
(display-completion-list (all-completions part-of-word
completions)))
(message "Making completion list...done")
+ ;; return value is handled by choose-completion-string-functions
nil))))
(defun bibtex-complete-string-cleanup (str)
@@ -2629,6 +2652,34 @@ non-nil.
(easy-menu-add bibtex-entry-menu)
(run-hooks 'bibtex-mode-hook))
+(defun bibtex-field-list (entry-type)
+ "Return list of allowed fields for entry ENTRY-TYPE.
+More specifically, the return value is a cons pair (REQUIRED . OPTIONAL),
+where REQUIRED and OPTIONAL are lists of the required and optional field
+names for ENTRY-TYPE according to `bibtex-entry-field-alist'."
+ (let ((e (assoc-string entry-type bibtex-entry-field-alist t))
+ required optional)
+ (unless e
+ (error "Bibtex entry type %s not defined" entry-type))
+ (if (and (member-ignore-case entry-type bibtex-include-OPTcrossref)
+ (nth 2 e))
+ (setq required (nth 0 (nth 2 e))
+ optional (nth 1 (nth 2 e)))
+ (setq required (nth 0 (nth 1 e))
+ optional (nth 1 (nth 1 e))))
+ (if bibtex-include-OPTkey
+ (push (list "key"
+ "Used for reference key creation if author and editor fields are missing"
+ (if (or (stringp bibtex-include-OPTkey)
+ (fboundp bibtex-include-OPTkey))
+ bibtex-include-OPTkey))
+ optional))
+ (if (member-ignore-case entry-type bibtex-include-OPTcrossref)
+ (push '("crossref" "Reference key of the cross-referenced entry")
+ optional))
+ (setq optional (append optional bibtex-user-optional-fields))
+ (cons required optional)))
+
(defun bibtex-entry (entry-type)
"Insert a new BibTeX entry.
After insertion it calls the functions in `bibtex-add-entry-hook'."
@@ -2638,38 +2689,17 @@ After insertion it calls the functions in `bibtex-add-entry-hook'."
bibtex-entry-field-alist
nil t nil 'bibtex-entry-type-history)))
(list e-t)))
- (let* (required optional
- (key (if bibtex-maintain-sorted-entries
- (bibtex-read-key (format "%s key: " entry-type))))
- (e (assoc-ignore-case entry-type bibtex-entry-field-alist))
- (r-n-o (elt e 1))
- (c-ref (elt e 2)))
- (if (not e)
- (error "Bibtex entry type %s not defined" entry-type))
- (if (and (member entry-type bibtex-include-OPTcrossref)
- c-ref)
- (setq required (elt c-ref 0)
- optional (elt c-ref 1))
- (setq required (elt r-n-o 0)
- optional (elt r-n-o 1)))
+ (let ((key (if bibtex-maintain-sorted-entries
+ (bibtex-read-key (format "%s key: " entry-type))))
+ (field-list (bibtex-field-list entry-type)))
(unless (bibtex-prepare-new-entry (list key nil entry-type))
(error "Entry with key `%s' already exists" key))
(indent-to-column bibtex-entry-offset)
(insert "@" entry-type (bibtex-entry-left-delimiter))
- (if key
- (insert key))
+ (if key (insert key))
(save-excursion
- (mapcar 'bibtex-make-field required)
- (if (member entry-type bibtex-include-OPTcrossref)
- (bibtex-make-optional-field '("crossref")))
- (if bibtex-include-OPTkey
- (if (or (stringp bibtex-include-OPTkey)
- (fboundp bibtex-include-OPTkey))
- (bibtex-make-optional-field
- (list "key" nil bibtex-include-OPTkey))
- (bibtex-make-optional-field '("key"))))
- (mapcar 'bibtex-make-optional-field optional)
- (mapcar 'bibtex-make-optional-field bibtex-user-optional-fields)
+ (mapcar 'bibtex-make-field (car field-list))
+ (mapcar 'bibtex-make-optional-field (cdr field-list))
(if bibtex-comma-after-last-field
(insert ","))
(insert "\n")
@@ -2680,15 +2710,39 @@ After insertion it calls the functions in `bibtex-add-entry-hook'."
(bibtex-autofill-entry))
(run-hooks 'bibtex-add-entry-hook)))
+(defun bibtex-entry-update ()
+ "Update an existing BibTeX entry.
+In the BibTeX entry at point, make new fields for those items that may occur
+according to `bibtex-entry-field-alist', but are not yet present."
+ (interactive)
+ (save-excursion
+ (bibtex-beginning-of-entry)
+ ;; For inserting new fields, we use the fact that
+ ;; bibtex-parse-entry moves point to the end of the last field.
+ (let* ((fields-alist (bibtex-parse-entry))
+ (field-list (bibtex-field-list
+ (substring (cdr (assoc "=type=" fields-alist))
+ 1))) ; don't want @
+ (case-fold-search t))
+ (dolist (field (car field-list))
+ (unless (bibtex-assoc-regexp (concat "\\`\\(ALT\\)?" (car field) "\\'")
+ fields-alist)
+ (bibtex-make-field field)))
+ (dolist (field (cdr field-list))
+ (unless (bibtex-assoc-regexp (concat "\\`\\(OPT\\)?" (car field) "\\'")
+ fields-alist)
+ (bibtex-make-optional-field field))))))
+
(defun bibtex-parse-entry ()
"Parse entry at point, return an alist.
The alist elements have the form (FIELD . TEXT), where FIELD can also be
-the special strings \"=type=\" and \"=key=\"."
+the special strings \"=type=\" and \"=key=\". For the FIELD \"=key=\"
+TEXT may be nil. Move point to the end of the last field."
(let (alist bounds)
- (when (looking-at bibtex-entry-head)
+ (when (looking-at bibtex-entry-maybe-empty-head)
(push (cons "=type=" (match-string bibtex-type-in-head)) alist)
(push (cons "=key=" (match-string bibtex-key-in-head)) alist)
- (goto-char (match-end bibtex-key-in-head))
+ (goto-char (match-end 0))
(while (setq bounds (bibtex-parse-field bibtex-field-name))
(push (cons (bibtex-name-in-field bounds)
(bibtex-text-in-field-bounds bounds))
@@ -2744,7 +2798,7 @@ the special strings \"=type=\" and \"=key=\"."
(let* ((name (buffer-substring
(if (looking-at "ALT\\|OPT") (match-end 0) (point))
(bibtex-end-of-name-in-field bounds)))
- (text (assoc-ignore-case name other)))
+ (text (assoc-string name other t)))
(goto-char (bibtex-start-of-text-in-field bounds))
(if (not (and (looking-at bibtex-empty-field-re) text))
(goto-char (bibtex-end-of-field bounds))
@@ -2774,28 +2828,15 @@ the special strings \"=type=\" and \"=key=\"."
(looking-at "OPT\\|ALT"))
(match-end 0) mb)
(bibtex-end-of-name-in-field bounds)))
- (entry-type (progn (re-search-backward
- bibtex-entry-maybe-empty-head nil t)
- (bibtex-type-in-head)))
- (entry-list (assoc-ignore-case entry-type
- bibtex-entry-field-alist))
- (c-r-list (elt entry-list 2))
- (req-opt-list (if (and (member entry-type
- bibtex-include-OPTcrossref)
- c-r-list)
- c-r-list
- (elt entry-list 1)))
- (list-of-entries (append (elt req-opt-list 0)
- (elt req-opt-list 1)
- bibtex-user-optional-fields
- (if (member entry-type
- bibtex-include-OPTcrossref)
- '(("crossref" "Reference key of the cross-referenced entry")))
- (if bibtex-include-OPTkey
- '(("key" "Used for reference key creation if author and editor fields are missing")))))
- (comment (assoc-ignore-case field-name list-of-entries)))
+ (field-list (bibtex-field-list (progn (re-search-backward
+ bibtex-entry-maybe-empty-head nil t)
+ (bibtex-type-in-head))))
+ (comment (assoc-string field-name
+ (append (car field-list)
+ (cdr field-list))
+ t)))
(if comment
- (message (elt comment 1))
+ (message (nth 1 comment))
(message "No comment available")))))
(defun bibtex-make-field (field &optional called-by-yank)
@@ -2804,24 +2845,13 @@ FIELD is either a string or a list of the form
\(FIELD-NAME COMMENT-STRING INIT ALTERNATIVE-FLAG) as in
`bibtex-entry-field-alist'."
(interactive
- (list (let* ((entry-type
- (save-excursion
- (bibtex-enclosing-entry-maybe-empty-head)
- (bibtex-type-in-head)))
- ;; "preliminary" completion list
- (fl (nth 1 (assoc-ignore-case
- entry-type bibtex-entry-field-alist)))
- ;; "full" completion list
- (field-list (append (nth 0 fl)
- (nth 1 fl)
- bibtex-user-optional-fields
- (if (member entry-type
- bibtex-include-OPTcrossref)
- '(("crossref")))
- (if bibtex-include-OPTkey
- '(("key")))))
- (completion-ignore-case t))
- (completing-read "BibTeX field name: " field-list
+ (list (let ((completion-ignore-case t)
+ (field-list (bibtex-field-list
+ (save-excursion
+ (bibtex-enclosing-entry-maybe-empty-head)
+ (bibtex-type-in-head)))))
+ (completing-read "BibTeX field name: "
+ (append (car field-list) (cdr field-list))
nil nil nil bibtex-field-history))))
(unless (consp field)
(setq field (list field)))
@@ -2848,8 +2878,9 @@ FIELD is either a string or a list of the form
((fboundp init)
(insert (funcall init)))))
(if (not called-by-yank) (insert (bibtex-field-right-delimiter)))
- (if (interactive-p)
- (forward-char -1)))
+ (when (interactive-p)
+ (forward-char -1)
+ (bibtex-print-help-message)))
(defun bibtex-beginning-of-entry ()
"Move to beginning of BibTeX entry (beginning of line).
@@ -2982,13 +3013,14 @@ the entries of the BibTeX buffer. Return nil if no entry found."
"\\(OPT\\)?crossref" t)))
(list key
(if bounds (bibtex-text-in-field-bounds bounds t))
- entry-name))))
- (list key nil entry-name)))))
+ entry-name)))
+ (list key nil entry-name))))))
(defun bibtex-lessp (index1 index2)
"Predicate for sorting BibTeX entries with indices INDEX1 and INDEX2.
Each index is a list (KEY CROSSREF-KEY ENTRY-NAME).
-The predicate depends on the variable `bibtex-maintain-sorted-entries'."
+The predicate depends on the variable `bibtex-maintain-sorted-entries'.
+If its value is nil use plain sorting."
(cond ((not index1) (not index2)) ; indices can be nil
((not index2) nil)
((equal bibtex-maintain-sorted-entries 'crossref)
@@ -3017,12 +3049,10 @@ The predicate depends on the variable `bibtex-maintain-sorted-entries'."
(defun bibtex-sort-buffer ()
"Sort BibTeX buffer alphabetically by key.
The predicate for sorting is defined via `bibtex-maintain-sorted-entries'.
-Text outside of BibTeX entries is not affected. If
-`bibtex-sort-ignore-string-entries' is non-nil, @String entries will be
-ignored."
+If its value is nil use plain sorting. Text outside of BibTeX entries is not
+affected. If `bibtex-sort-ignore-string-entries' is non-nil, @String entries
+will be ignored."
(interactive)
- (unless bibtex-maintain-sorted-entries
- (error "You must choose a sorting scheme"))
(save-restriction
(narrow-to-region (bibtex-beginning-of-first-entry)
(save-excursion (goto-char (point-max))
@@ -3212,8 +3242,8 @@ Returns t if test was successful, nil otherwise."
(let* ((entry-list (progn
(goto-char beg)
(bibtex-search-entry nil end)
- (assoc-ignore-case (bibtex-type-in-head)
- bibtex-entry-field-alist)))
+ (assoc-string (bibtex-type-in-head)
+ bibtex-entry-field-alist t)))
(req (copy-sequence (elt (elt entry-list 1) 0)))
(creq (copy-sequence (elt (elt entry-list 2) 0)))
crossref-there bounds)
@@ -3229,8 +3259,8 @@ Returns t if test was successful, nil otherwise."
(push (list (bibtex-current-line)
"Questionable month field")
error-list))
- (setq req (delete (assoc-ignore-case field-name req) req)
- creq (delete (assoc-ignore-case field-name creq) creq))
+ (setq req (delete (assoc-string field-name req t) req)
+ creq (delete (assoc-string field-name creq t) creq))
(if (equal field-name "crossref")
(setq crossref-there t))))
(if crossref-there
@@ -3523,27 +3553,30 @@ At end of the cleaning process, the functions in
(match-end bibtex-key-in-head)))
(insert key))
;; sorting
- (let* ((start (bibtex-beginning-of-entry))
- (end (progn (bibtex-end-of-entry)
- (if (re-search-forward
- bibtex-entry-maybe-empty-head nil 'move)
- (goto-char (match-beginning 0)))
- (point)))
- (entry (buffer-substring start end))
- (index (progn (goto-char start)
- (bibtex-entry-index))))
- (delete-region start end)
- (unless (prog1 (or called-by-reformat
- (if (and bibtex-maintain-sorted-entries
- (not (and bibtex-sort-ignore-string-entries
- (equal entry-type "string"))))
- (bibtex-prepare-new-entry index)
- (not (bibtex-find-entry (car index)))))
- (insert entry)
- (forward-char -1)
- (bibtex-beginning-of-entry) ; moves backward
- (re-search-forward bibtex-entry-head))
- (error "New inserted entry yields duplicate key")))
+ (unless called-by-reformat
+ (let* ((start (bibtex-beginning-of-entry))
+ (end (progn (bibtex-end-of-entry)
+ (if (re-search-forward
+ bibtex-entry-maybe-empty-head nil 'move)
+ (goto-char (match-beginning 0)))
+ (point)))
+ (entry (buffer-substring start end))
+ (index (progn (goto-char start)
+ (bibtex-entry-index)))
+ no-error)
+ (if (and bibtex-maintain-sorted-entries
+ (not (and bibtex-sort-ignore-string-entries
+ (equal entry-type "string"))))
+ (progn
+ (delete-region start end)
+ (setq no-error (bibtex-prepare-new-entry index))
+ (insert entry)
+ (forward-char -1)
+ (bibtex-beginning-of-entry) ; moves backward
+ (re-search-forward bibtex-entry-head))
+ (setq no-error (bibtex-find-entry (car index))))
+ (unless no-error
+ (error "New inserted entry yields duplicate key"))))
;; final clean up
(unless called-by-reformat
(save-excursion
@@ -3621,91 +3654,89 @@ If `bibtex-align-at-equal-sign' is non-nil, align equal signs, too."
(indent-to-column bibtex-entry-offset)
(goto-char pnt)))
-(defun bibtex-reformat (&optional additional-options called-by-convert-alien)
+(defun bibtex-realign ()
+ "Realign BibTeX entries such that they are separated by one blank line."
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (when (looking-at bibtex-valid-entry-whitespace-re)
+ (replace-match "\\1"))
+ (while (re-search-forward bibtex-valid-entry-whitespace-re nil t)
+ (replace-match "\n\n\\1"))))
+
+(defun bibtex-reformat (&optional read-options)
"Reformat all BibTeX entries in buffer or region.
With prefix argument, read options for reformatting from minibuffer.
With \\[universal-argument] \\[universal-argument] prefix argument, reuse previous answers (if any) again.
-If mark is active it reformats entries in region, if not in whole buffer."
+If mark is active reformat entries in region, if not in whole buffer."
(interactive "*P")
(let* ((pnt (point))
(use-previous-options
- (and (equal (prefix-numeric-value additional-options) 16)
+ (and (equal (prefix-numeric-value read-options) 16)
(or bibtex-reformat-previous-options
bibtex-reformat-previous-reference-keys)))
(bibtex-entry-format
- (if additional-options
+ (if read-options
(if use-previous-options
bibtex-reformat-previous-options
(setq bibtex-reformat-previous-options
- (delq nil (list
- (if (or called-by-convert-alien
- (y-or-n-p "Realign entries (recommended)? "))
- 'realign)
- (if (y-or-n-p "Remove empty optional and alternative fields? ")
- 'opts-or-alts)
- (if (y-or-n-p "Remove delimiters around pure numerical fields? ")
- 'numerical-fields)
- (if (y-or-n-p (concat (if bibtex-comma-after-last-field "Insert" "Remove")
- " comma at end of entry? "))
- 'last-comma)
- (if (y-or-n-p "Replace double page dashes by single ones? ")
- 'page-dashes)
- (if (y-or-n-p "Force delimiters? ")
- 'delimiters)
- (if (y-or-n-p "Unify case of entry types and field names? ")
- 'unify-case)))))
+ (mapcar (lambda (option)
+ (if (y-or-n-p (car option)) (cdr option)))
+ `(("Realign entries (recommended)? " . 'realign)
+ ("Remove empty optional and alternative fields? " . 'opts-or-alts)
+ ("Remove delimiters around pure numerical fields? " . 'numerical-fields)
+ (,(concat (if bibtex-comma-after-last-field "Insert" "Remove")
+ " comma at end of entry? ") . 'last-comma)
+ ("Replace double page dashes by single ones? " . 'page-dashes)
+ ("Force delimiters? " . 'delimiters)
+ ("Unify case of entry types and field names? " . 'unify-case)))))
'(realign)))
- (reformat-reference-keys (if additional-options
- (if use-previous-options
- bibtex-reformat-previous-reference-keys
- (setq bibtex-reformat-previous-reference-keys
- (y-or-n-p "Generate new reference keys automatically? ")))))
- bibtex-autokey-edit-before-use
- (bibtex-sort-ignore-string-entries t)
+ (reformat-reference-keys
+ (if read-options
+ (if use-previous-options
+ bibtex-reformat-previous-reference-keys
+ (setq bibtex-reformat-previous-reference-keys
+ (y-or-n-p "Generate new reference keys automatically? ")))))
(start-point (if (bibtex-mark-active)
(region-beginning)
- (bibtex-beginning-of-first-entry)
- (bibtex-skip-to-valid-entry)
- (point)))
+ (point-min)))
(end-point (if (bibtex-mark-active)
(region-end)
- (point-max))))
+ (point-max)))
+ (bibtex-sort-ignore-string-entries t)
+ bibtex-autokey-edit-before-use)
+
(save-restriction
(narrow-to-region start-point end-point)
- (when (memq 'realign bibtex-entry-format)
- (goto-char (point-min))
- (while (re-search-forward bibtex-valid-entry-whitespace-re nil t)
- (replace-match "\n\\1")))
+ (if (memq 'realign bibtex-entry-format)
+ (bibtex-realign))
(goto-char start-point)
(bibtex-progress-message "Formatting" 1)
(bibtex-map-entries (lambda (key beg end)
(bibtex-progress-message)
- (bibtex-clean-entry reformat-reference-keys t)
- (when (memq 'realign bibtex-entry-format)
- (goto-char end)
- (bibtex-delete-whitespace)
- (open-line 2))))
+ (bibtex-clean-entry reformat-reference-keys t)))
+ (when (memq 'realign bibtex-entry-format)
+ (bibtex-delete-whitespace)
+ (open-line (if (eobp) 1 2)))
(bibtex-progress-message 'done))
(when (and reformat-reference-keys
- bibtex-maintain-sorted-entries
- (not called-by-convert-alien))
+ bibtex-maintain-sorted-entries)
+ (bibtex-progress-message "Sorting" 1)
(bibtex-sort-buffer)
- (kill-local-variable 'bibtex-reference-keys))
+ (kill-local-variable 'bibtex-reference-keys)
+ (bibtex-progress-message 'done))
(goto-char pnt)))
-(defun bibtex-convert-alien (&optional do-additional-reformatting)
+(defun bibtex-convert-alien (&optional read-options)
"Convert an alien BibTeX buffer to be fully usable by BibTeX mode.
-If a file does not conform with some standards used by BibTeX mode,
+If a file does not conform with all standards used by BibTeX mode,
some of the high-level features of BibTeX mode will not be available.
This function tries to convert current buffer to conform with these standards.
-With prefix argument DO-ADDITIONAL-REFORMATTING
-non-nil, read options for reformatting entries from minibuffer."
+With prefix argument READ-OPTIONS non-nil, read options for reformatting
+entries from minibuffer."
(interactive "*P")
(message "Starting to validate buffer...")
(sit-for 1 nil t)
- (goto-char (point-min))
- (while (re-search-forward "[ \t\n]+@" nil t)
- (replace-match "\n@"))
+ (bibtex-realign)
(message
"If errors occur, correct them and call `bibtex-convert-alien' again")
(sit-for 5 nil t)
@@ -3714,10 +3745,7 @@ non-nil, read options for reformatting entries from minibuffer."
(bibtex-validate))
(message "Starting to reformat entries...")
(sit-for 2 nil t)
- (bibtex-reformat do-additional-reformatting t)
- (when bibtex-maintain-sorted-entries
- (message "Starting to sort buffer...")
- (bibtex-sort-buffer))
+ (bibtex-reformat read-options)
(goto-char (point-max))
(message "Buffer is now parsable. Please save it.")))
@@ -3890,5 +3918,5 @@ is outside key or BibTeX field."
(provide 'bibtex)
-;;; arch-tag: ee2be3af-caad-427f-b42a-d20fad630d04
+;; arch-tag: ee2be3af-caad-427f-b42a-d20fad630d04
;;; bibtex.el ends here
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
index aaa10fbce5f..a888003402d 100644
--- a/lisp/textmodes/fill.el
+++ b/lisp/textmodes/fill.el
@@ -155,7 +155,7 @@ Leave one space between words, two at end of sentences or after colons
and `sentence-end-without-period').
Remove indentation from each line."
(interactive "*r")
- (let ((end-spc-re (concat "\\(" sentence-end "\\) *\\| +")))
+ (let ((end-spc-re (concat "\\(" (sentence-end) "\\) *\\| +")))
(save-excursion
(goto-char beg)
;; Nuke tabs; they get screwed up in a fill.
@@ -349,7 +349,7 @@ and `fill-nobreak-invisible'."
(save-excursion
(skip-chars-backward ". ")
(and (looking-at "\\.")
- (not (looking-at sentence-end))))
+ (not (looking-at (sentence-end)))))
;; Don't split a line if the rest would look like a new paragraph.
(unless use-hard-newlines
(save-excursion
@@ -424,10 +424,10 @@ Point is moved to just past the fill prefix on the first line."
;; loses on split abbrevs ("Mr.\nSmith")
(let ((eol-double-space-re
(cond
- ((not colon-double-space) (concat sentence-end "$"))
+ ((not colon-double-space) (concat (sentence-end) "$"))
;; Try to add the : inside the `sentence-end' regexp.
- ((string-match "\\[[^][]*\\(\\.\\)[^][]*\\]" sentence-end)
- (concat (replace-match ".:" nil nil sentence-end 1) "$"))
+ ((string-match "\\[[^][]*\\(\\.\\)[^][]*\\]" (sentence-end))
+ (concat (replace-match ".:" nil nil (sentence-end) 1) "$"))
;; Can't find the right spot to insert the colon.
(t "[.?!:][])}\"']*$")))
(sentence-end-without-space-list
diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el
index 3d41042e8d7..aff42866349 100644
--- a/lisp/textmodes/flyspell.el
+++ b/lisp/textmodes/flyspell.el
@@ -3,6 +3,7 @@
;; Copyright (C) 1998, 2000, 2001, 2002 Free Software Foundation, Inc.
;; Author: Manuel Serrano <Manuel.Serrano@unice.fr>
+;; Maintainer: FSF
;; Keywords: convenience
;; This file is part of GNU Emacs.
@@ -1516,46 +1517,51 @@ for the overlay."
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-incorrect-region (beg end poss)
"Set up an overlay on a misspelled word, in the buffer from BEG to END."
- (unless (run-hook-with-args-until-success
- 'flyspell-incorrect-hook beg end poss)
- (if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
- (progn
- ;; we cleanup current overlay at the same position
- (if (and (not flyspell-persistent-highlight)
- (overlayp flyspell-overlay))
- (delete-overlay flyspell-overlay)
- (let ((overlays (overlays-at beg)))
- (while (consp overlays)
- (if (flyspell-overlay-p (car overlays))
- (delete-overlay (car overlays)))
- (setq overlays (cdr overlays)))))
- ;; now we can use a new overlay
- (setq flyspell-overlay
- (make-flyspell-overlay beg end
- 'flyspell-incorrect-face
- 'highlight))))))
+ (let ((inhibit-read-only t))
+ (unless (run-hook-with-args-until-success
+ 'flyspell-incorrect-hook beg end poss)
+ (if (or flyspell-highlight-properties
+ (not (flyspell-properties-at-p beg)))
+ (progn
+ ;; we cleanup current overlay at the same position
+ (if (and (not flyspell-persistent-highlight)
+ (overlayp flyspell-overlay))
+ (delete-overlay flyspell-overlay)
+ (let ((overlays (overlays-at beg)))
+ (while (consp overlays)
+ (if (flyspell-overlay-p (car overlays))
+ (delete-overlay (car overlays)))
+ (setq overlays (cdr overlays)))))
+ ;; now we can use a new overlay
+ (setq flyspell-overlay
+ (make-flyspell-overlay
+ beg end 'flyspell-incorrect-face 'highlight)))))))
;*---------------------------------------------------------------------*/
;* flyspell-highlight-duplicate-region ... */
;*---------------------------------------------------------------------*/
(defun flyspell-highlight-duplicate-region (beg end)
"Set up an overlay on a duplicated word, in the buffer from BEG to END."
- (if (or flyspell-highlight-properties (not (flyspell-properties-at-p beg)))
- (progn
- ;; we cleanup current overlay at the same position
- (if (and (not flyspell-persistent-highlight)
- (overlayp flyspell-overlay))
- (delete-overlay flyspell-overlay)
- (let ((overlays (overlays-at beg)))
- (while (consp overlays)
- (if (flyspell-overlay-p (car overlays))
- (delete-overlay (car overlays)))
- (setq overlays (cdr overlays)))))
- ;; now we can use a new overlay
- (setq flyspell-overlay
- (make-flyspell-overlay beg end
- 'flyspell-duplicate-face
- 'highlight)))))
+ (let ((inhibit-read-only t))
+ (unless (run-hook-with-args-until-success
+ 'flyspell-incorrect-hook beg end poss)
+ (if (or flyspell-highlight-properties
+ (not (flyspell-properties-at-p beg)))
+ (progn
+ ;; we cleanup current overlay at the same position
+ (if (and (not flyspell-persistent-highlight)
+ (overlayp flyspell-overlay))
+ (delete-overlay flyspell-overlay)
+ (let ((overlays (overlays-at beg)))
+ (while (consp overlays)
+ (if (flyspell-overlay-p (car overlays))
+ (delete-overlay (car overlays)))
+ (setq overlays (cdr overlays)))))
+ ;; now we can use a new overlay
+ (setq flyspell-overlay
+ (make-flyspell-overlay beg end
+ 'flyspell-duplicate-face
+ 'highlight)))))))
;*---------------------------------------------------------------------*/
;* flyspell-auto-correct-cache ... */
@@ -2061,23 +2067,23 @@ possible corrections as returned by 'ispell-parse-output'.
This function is meant to be added to 'flyspell-incorrect-hook'."
(when (consp poss)
- (let ((temp-buffer (get-buffer-create " *flyspell-temp*"))
- found)
- (save-excursion
- (copy-to-buffer temp-buffer beg end)
- (set-buffer temp-buffer)
- (goto-char (1+ (point-min)))
- (while (and (not (eobp)) (not found))
- (transpose-chars 1)
- (if (member (buffer-string) (nth 2 poss))
- (setq found (point))
- (transpose-chars -1)
- (forward-char))))
- (when found
- (save-excursion
- (goto-char (+ beg found -1))
- (transpose-chars -1)
- t)))))
+ (catch 'done
+ (let ((str (buffer-substring beg end))
+ (i 0) (len (- end beg)) tmp)
+ (while (< (1+ i) len)
+ (setq tmp (aref str i))
+ (aset str i (aref str (1+ i)))
+ (aset str (1+ i) tmp)
+ (when (member str (nth 2 poss))
+ (save-excursion
+ (goto-char (+ beg i 1))
+ (transpose-chars 1))
+ (throw 'done t))
+ (setq tmp (aref str i))
+ (aset str i (aref str (1+ i)))
+ (aset str (1+ i) tmp)
+ (setq i (1+ i))))
+ nil)))
(defun flyspell-maybe-correct-doubling (beg end poss)
"Check replacements for doubled characters.
@@ -2091,24 +2097,19 @@ possible corrections as returned by 'ispell-parse-output'.
This function is meant to be added to 'flyspell-incorrect-hook'."
(when (consp poss)
- (let ((temp-buffer (get-buffer-create " *flyspell-temp*"))
- found)
- (save-excursion
- (copy-to-buffer temp-buffer beg end)
- (set-buffer temp-buffer)
- (goto-char (1+ (point-min)))
- (while (and (not (eobp)) (not found))
- (when (char-equal (char-after) (char-before))
- (delete-char 1)
- (if (member (buffer-string) (nth 2 poss))
- (setq found (point))
- (insert-char (char-before) 1)))
- (forward-char)))
- (when found
- (save-excursion
- (goto-char (+ beg found -1))
- (delete-char 1)
- t)))))
+ (catch 'done
+ (let ((str (buffer-substring beg end))
+ (i 0) (len (- end beg)))
+ (while (< (1+ i) len)
+ (when (and (= (aref str i) (aref str (1+ i)))
+ (member (concat (substring str 0 (1+ i))
+ (substring str (+ i 2)))
+ (nth 2 poss)))
+ (goto-char (+ beg i))
+ (delete-char 1)
+ (throw 'done t))
+ (setq i (1+ i))))
+ nil)))
;*---------------------------------------------------------------------*/
;* flyspell-already-abbrevp ... */
diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el
index 39fe89bdaaa..77c63379e2b 100644
--- a/lisp/textmodes/ispell.el
+++ b/lisp/textmodes/ispell.el
@@ -501,7 +501,8 @@ and then re-start emacs."
(choice :tag "Coding system"
(const iso-8859-1)
(const iso-8859-2)
- (const koi8-r))))
+ (const koi8-r)
+ (const windows-1251))))
:group 'ispell)
@@ -630,6 +631,10 @@ and then re-start emacs."
"[\341\342\367\347\344\345\263\366\372\351\352\353\354\355\356\357\360\362\363\364\365\346\350\343\376\373\375\370\371\377\374\340\361\301\302\327\307\304\305\243\326\332\311\312\313\314\315\316\317\320\322\323\324\325\306\310\303\336\333\335\330\331\337\334\300\321]"
"[^\341\342\367\347\344\345\263\366\372\351\352\353\354\355\356\357\360\362\363\364\365\346\350\343\376\373\375\370\371\377\374\340\361\301\302\327\307\304\305\243\326\332\311\312\313\314\315\316\317\320\322\323\324\325\306\310\303\336\333\335\330\331\337\334\300\321]"
"" nil nil nil koi8-r)
+ ("russianw" ; russianw.aff (CP1251 charset)
+ "[\300\301\302\303\304\305\250\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\334\333\332\335\336\337\340\341\342\343\344\345\270\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\374\373\372\375\376\377]"
+ "[^\300\301\302\303\304\305\250\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\334\333\332\335\336\337\340\341\342\343\344\345\270\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\374\373\372\375\376\377]"
+ "" nil nil nil windows-1251)
("slovak" ; Slovakian
"[A-Za-z\301\304\311\315\323\332\324\300\305\245\335\256\251\310\317\253\322\341\344\351\355\363\372\364\340\345\265\375\276\271\350\357\273\362]"
"[^A-Za-z\301\304\311\315\323\332\324\300\305\245\335\256\251\310\317\253\322\341\344\351\355\363\372\364\340\345\265\375\276\271\350\357\273\362]"
@@ -3274,7 +3279,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to
(equal major-mode 'message-mode)) ;GNUS 5
(concat "In article <" "\\|"
"[^,;&+=\n]+ <[^,;&+=]+> writes:" "\\|"
- message-yank-prefix "\\|"
+ message-cite-prefix-regexp "\\|"
default-prefix))
((equal major-mode 'mh-letter-mode) ; mh mail message
(concat "[^,;&+=\n]+ writes:" "\\|"
diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el
index f7595e24cb5..e9cc4f397de 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/textmodes/paragraphs.el
@@ -120,49 +120,62 @@ text indented by a margin setting."
This is relevant for filling. See also `sentence-end-without-period'
and `colon-double-space'.
-If you change this, you should also change `sentence-end'. See Info
-node `Sentences'."
+This value is used by the function `sentence-end' to construct the
+regexp describing the end of a sentence, in case when the value of
+the variable `sentence-end' is nil. See Info node `Sentences'."
:type 'boolean
:group 'fill)
(defcustom sentence-end-without-period nil
"*Non-nil means a sentence will end without a period.
For example, a sentence in Thai text ends with double space but
-without a period."
+without a period.
+
+This value is used by the function `sentence-end' to construct the
+regexp describing the end of a sentence, in case when the value of
+the variable `sentence-end' is nil. See Info node `Sentences'."
:type 'boolean
:group 'fill)
(defcustom sentence-end-without-space
"$B!#!%!)!*$A!##.#?#!$(0!$!%!)!*$(G!$!%!)!*(B"
"*String containing characters that end sentence without following spaces.
-If you change this, you should also change `sentence-end'. See Info
-node `Sentences'."
+
+This value is used by the function `sentence-end' to construct the
+regexp describing the end of a sentence, in case when the value of
+the variable `sentence-end' is nil. See Info node `Sentences'."
:group 'paragraphs
:type 'string)
-(defcustom sentence-end
- (purecopy
- ;; This is a bit stupid since it's not auto-updated when the
- ;; other variables are changes, but it's still useful info.
- (concat (if sentence-end-without-period "\\w \\|")
- "\\([.?!][]\"')}]*"
- (if sentence-end-double-space
- "\\($\\| $\\|\t\\| \\)" "\\($\\|[\t ]\\)")
- "\\|[" sentence-end-without-space "]+\\)"
- "[ \t\n]*"))
+(defcustom sentence-end nil
"*Regexp describing the end of a sentence.
The value includes the whitespace following the sentence.
All paragraph boundaries also end sentences, regardless.
-The default value specifies that in order to be recognized as the end
-of a sentence, the ending period, question mark, or exclamation point
-must be followed by two spaces, unless it's inside some sort of quotes
-or parenthesis.
-
-See also the variable `sentence-end-double-space', the variable
-`sentence-end-without-period' and Info node `Sentences'."
+The value nil means to use the default value defined by the
+function `sentence-end'. You should always use this function
+to obtain the value of this variable."
:group 'paragraphs
- :type 'regexp)
+ :type '(choice regexp (const :tag "Use default value" nil)))
+
+(defun sentence-end ()
+ "Return the regexp describing the end of a sentence.
+
+This function returns either the value of the variable `sentence-end'
+if it is non-nil, or the default value constructed from the
+variables `sentence-end-double-space', `sentence-end-without-period'
+and `sentence-end-without-space'. The default value specifies
+that in order to be recognized as the end of a sentence, the
+ending period, question mark, or exclamation point must be
+followed by two spaces, unless it's inside some sort of quotes or
+parenthesis. See Info node `Sentences'."
+ (or sentence-end
+ (concat (if sentence-end-without-period "\\w \\|")
+ "\\([.?!][]\"'\xd0c9\x5397d)}]*"
+ (if sentence-end-double-space
+ "\\($\\| $\\|\t\\| \\)" "\\($\\|[\t ]\\)")
+ "\\|[" sentence-end-without-space "]+\\)"
+ "[ \t\n]*")))
(defcustom page-delimiter "^\014"
"*Regexp describing line-beginnings that separate pages."
@@ -411,7 +424,8 @@ The variable `sentence-end' is a regular expression that matches ends of
sentences. Also, every paragraph boundary terminates sentences as well."
(interactive "p")
(or arg (setq arg 1))
- (let ((opoint (point)))
+ (let ((opoint (point))
+ (sentence-end (sentence-end)))
(while (< arg 0)
(let ((pos (point))
(par-beg (save-excursion (start-of-paragraph-text) (point))))
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index 0497a823049..b3c69ca657f 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -636,7 +636,15 @@ Leaves the region surrounding the rectangle."
(define-key picture-mode-map "\C-c`" 'picture-movement-nw)
(define-key picture-mode-map "\C-c'" 'picture-movement-ne)
(define-key picture-mode-map "\C-c/" 'picture-movement-sw)
- (define-key picture-mode-map "\C-c\\" 'picture-movement-se)))
+ (define-key picture-mode-map "\C-c\\" 'picture-movement-se)
+ (define-key picture-mode-map [(control ?c) left] 'picture-movement-left)
+ (define-key picture-mode-map [(control ?c) right] 'picture-movement-right)
+ (define-key picture-mode-map [(control ?c) up] 'picture-movement-up)
+ (define-key picture-mode-map [(control ?c) down] 'picture-movement-down)
+ (define-key picture-mode-map [(control ?c) home] 'picture-movement-nw)
+ (define-key picture-mode-map [(control ?c) prior] 'picture-movement-ne)
+ (define-key picture-mode-map [(control ?c) end] 'picture-movement-sw)
+ (define-key picture-mode-map [(control ?c) next] 'picture-movement-se)))
(defcustom picture-mode-hook nil
"If non-nil, its value is called on entry to Picture mode.
diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el
index 93ea3cc0c14..7b13d498b2e 100644
--- a/lisp/textmodes/table.el
+++ b/lisp/textmodes/table.el
@@ -1,11 +1,11 @@
;;; table.el --- create and edit WYSIWYG text based embedded tables
-;; Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 01, 02, 03, 04 Free Software Foundation, Inc.
;; Keywords: wp, convenience
;; Author: Takaaki Ota <Takaaki.Ota@am.sony.com>
;; Created: Sat Jul 08 2000 13:28:45 (PST)
-;; Revised: Tue Dec 09 2003 14:36:50 (PST)
+;; Revised: Tue Jun 01 2004 11:36:39 (PDT)
;; This file is part of GNU Emacs.
@@ -1410,6 +1410,8 @@ the last cache point coordinate."
end-of-buffer
forward-word
backward-word
+ forward-sentence
+ backward-sentence
forward-paragraph
backward-paragraph))
@@ -1434,9 +1436,18 @@ the last cache point coordinate."
(cons (cons command func-symbol)
table-command-remap-alist))))
'(kill-region
+ kill-ring-save
delete-region
copy-region-as-kill
- kill-line))
+ kill-line
+ kill-word
+ backward-kill-word
+ kill-sentence
+ backward-kill-sentence
+ kill-paragraph
+ backward-kill-paragraph
+ kill-sexp
+ backward-kill-sexp))
;; Pasting Group
(mapcar
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 75a064c8959..c35ba53dbaa 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -1944,21 +1944,22 @@ for the error messages."
(or (null last-filename)
(not (string-equal last-filename filename))))
(error-location
- (save-excursion
- (if (equal filename (concat tex-zap-file ".tex"))
- (set-buffer tex-last-buffer-texed)
- (set-buffer (find-file-noselect filename)))
- (if new-file
- (progn (goto-line linenum) (setq last-position nil))
- (goto-char last-position)
- (forward-line (- linenum last-linenum)))
- ;; first try a forward search for the error text,
- ;; then a backward search limited by the last error.
- (let ((starting-point (point)))
- (or (re-search-forward error-text nil t)
- (re-search-backward error-text last-position t)
- (goto-char starting-point)))
- (point-marker))))
+ (with-current-buffer
+ (if (equal filename (concat tex-zap-file ".tex"))
+ tex-last-buffer-texed
+ (find-file-noselect filename))
+ (save-excursion
+ (if new-file
+ (progn (goto-line linenum) (setq last-position nil))
+ (goto-char last-position)
+ (forward-line (- linenum last-linenum)))
+ ;; first try a forward search for the error text,
+ ;; then a backward search limited by the last error.
+ (let ((starting-point (point)))
+ (or (re-search-forward error-text nil t)
+ (re-search-backward error-text last-position t)
+ (goto-char starting-point)))
+ (point-marker)))))
(goto-char this-error)
(if (and compilation-error-list
(or (and find-at-least
diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el
index 3e79d18a108..cc382b70528 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/textmodes/texinfmt.el
@@ -2899,7 +2899,7 @@ Default is to leave paragraph indentation as is."
1))
(symbol-value indexvar)))))
-(defconst texinfo-indexvar-alist
+(defvar texinfo-indexvar-alist
'(("cp" . texinfo-cindex)
("fn" . texinfo-findex)
("vr" . texinfo-vindex)
@@ -3032,7 +3032,7 @@ Default is to leave paragraph indentation as is."
(indent-to 54)
(insert
(if (nth 2 (car indexelts))
- (format " %d." (nth 2 (car indexelts)))
+ (format " (line %3d)" (1+ (nth 2 (car indexelts))))
"")
"\n"))
;; index entries from @include'd file
diff --git a/lisp/thumbs.el b/lisp/thumbs.el
index cc692c1f975..1fbf2d224a2 100644
--- a/lisp/thumbs.el
+++ b/lisp/thumbs.el
@@ -1,15 +1,10 @@
;;; thumbs.el --- Thumbnails previewer for images files
-;;;
+
+;; Copyright 2004 Free Software Foundation, Inc
+
;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
-;;
-;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some time
-;; The peoples at #emacs@freenode.net for numerous help
-;; RMS for emacs and the GNU project.
-;;
;; Keywords: Multimedia
-(defconst thumbs-version "2.0")
-
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
@@ -26,6 +21,11 @@
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
+;;
+;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some time
+;; The peoples at #emacs@freenode.net for numerous help
+;; RMS for emacs and the GNU project.
+;;
;;; Commentary:
@@ -52,21 +52,12 @@
;; for that image. C-h m will give you a list of available keybinding.
;;; History:
-;;
+;;
;;; Code:
(require 'dired)
-;; Abort if in-line imaging isn't supported (i.e. Emacs-20.7)
-
-(when (not (display-images-p))
- (error "Your Emacs version (%S) doesn't support in-line images,
-was not compiled with image support or is run in console mode.
-Upgrade to Emacs 21.1 or newer, compile it with image support
-or use a window-system"
- emacs-version))
-
;; CUSTOMIZATIONS
(defgroup thumbs nil
@@ -148,26 +139,26 @@ see some of your images."
:group 'thumbs)
;; Initialize some variable, for later use.
-(defvar thumbs-temp-file
- (concat thumbs-temp-dir thumbs-temp-prefix)
+(defvar thumbs-temp-file
+ (concat thumbs-temp-dir thumbs-temp-prefix)
"Temporary filesname for images.")
-(defvar thumbs-current-tmp-filename
- nil
+(defvar thumbs-current-tmp-filename
+ nil
"Temporary filename of current image.")
-(defvar thumbs-current-image-filename
+(defvar thumbs-current-image-filename
nil
"Filename of current image.")
-(defvar thumbs-current-image-size
+(defvar thumbs-current-image-size
nil
"Size of current image.")
-(defvar thumbs-image-num
+(defvar thumbs-image-num
nil
"Number of current image.")
-(defvar thumbs-current-dir
+(defvar thumbs-current-dir
nil
"Current directory.")
-(defvar thumbs-markedL
+(defvar thumbs-markedL
nil
"List of marked files.")
@@ -182,25 +173,6 @@ see some of your images."
(make-directory thumbs-thumbsdir)
(message "Creating thumbnails directory")))
-(when (not (fboundp 'ignore-errors))
- (defmacro ignore-errors (&rest body)
- "Execute FORMS; if anz error occurs, return nil.
-Otherwise, return result of last FORM."
- (let ((err (thumbs-gensym)))
- (list 'condition-case err (cons 'progn body) '(error nil)))))
-
-(when (not (fboundp 'time-less-p))
- (defun time-less-p (t1 t2)
- "Say whether time T1 is less than time T2."
- (or (< (car t1) (car t2))
- (and (= (car t1) (car t2))
- (< (nth 1 t1) (nth 1 t2))))))
-
-(when (not (fboundp 'caddar))
- (defun caddar (x)
- "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
- (car (cdr (cdr (car x))))))
-
(defvar thumbs-gensym-counter 0)
(defun thumbs-gensym (&optional arg)
@@ -208,7 +180,7 @@ Otherwise, return result of last FORM."
The name is made by appending a number to PREFIX, default \"Thumbs\"."
(let ((prefix (if (stringp arg) arg "Thumbs"))
(num (if (integerp arg) arg
- (prog1
+ (prog1
thumbs-gensym-counter
(setq thumbs-gensym-counter (1+ thumbs-gensym-counter))))))
(make-symbol (format "%s%d" prefix num))))
@@ -229,9 +201,9 @@ reached."
(dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL))))
(while (> dirsize thumbs-thumbsdir-max-size)
(progn
- (message "Deleting file %s" (caddar filesL)))
- (delete-file (caddar filesL))
- (setq dirsize (- dirsize (cadar filesL)))
+ (message "Deleting file %s" (cadr (cdar filesL))))
+ (delete-file (cadr (cdar filesL)))
+ (setq dirsize (- dirsize (car (cdar filesL))))
(setq filesL (cdr filesL)))))
;; Check the thumbsnail directory size and clean it if necessary.
@@ -274,7 +246,7 @@ ACTION-PREFIX is the symbol to place before the ACTION command
thumbs-image-resizing-step)
(thumbs-increment-image-size-element (cdr s)
thumbs-image-resizing-step)))
-
+
(defun thumbs-decrement-image-size (s)
"Decrement S (a cons of width x heigh)."
(cons
@@ -289,11 +261,12 @@ if INCREMENT is set, make the image bigger, else smaller.
Or, alternatively, a SIZE may be specified."
(interactive)
;; cleaning of old temp file
- (ignore-errors
+ (condition-case nil
(apply 'delete-file
(directory-files
thumbs-temp-dir t
- thumbs-temp-prefix)))
+ thumbs-temp-prefix))
+ (error nil))
(let ((buffer-read-only nil)
(x (if size
size
@@ -315,7 +288,7 @@ Or, alternatively, a SIZE may be specified."
"Resize Image interactively to specified WIDTH and HEIGHT."
(interactive "nWidth: \nnHeight: ")
(thumbs-resize-image nil (cons width height)))
-
+
(defun thumbs-resize-image-size-down ()
"Resize image (smaller)."
(interactive)
@@ -326,22 +299,10 @@ Or, alternatively, a SIZE may be specified."
(interactive)
(thumbs-resize-image t))
-(defun thumbs-subst-char-in-string (orig rep string)
- "Replace occurrences of character ORIG with character REP in STRING.
-Return the resulting (new) string. -- (defun borowed to Dave Love)"
- (let ((string (copy-sequence string))
- (l (length string))
- (i 0))
- (while (< i l)
- (if (= (aref string i) orig)
- (aset string i rep))
- (setq i (1+ i)))
- string))
-
(defun thumbs-thumbname (img)
"Return a thumbnail name for the image IMG."
(concat thumbs-thumbsdir "/"
- (thumbs-subst-char-in-string
+ (subst-char-in-string
?\ ?\_
(apply
'concat
@@ -353,10 +314,14 @@ Return the resulting (new) string. -- (defun borowed to Dave Love)"
(let* ((fn (expand-file-name img))
(tn (thumbs-thumbname img)))
(if (or (not (file-exists-p tn))
- (not (equal (thumbs-file-size tn) thumbs-geometry)))
+ ;; This is not the right fix, but I don't understand
+ ;; the external program or why it produces a geometry
+ ;; unequal to the one requested -- rms.
+;;; (not (equal (thumbs-file-size tn) thumbs-geometry))
+ )
(thumbs-call-convert fn tn "sample" thumbs-geometry))
tn))
-
+
(defun thumbs-image-type (img)
"Return image type from filename IMG."
(cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg)
@@ -372,7 +337,7 @@ Return the resulting (new) string. -- (defun borowed to Dave Love)"
(concat (number-to-string (round (car i)))
"x"
(number-to-string (round (cdr i))))))
-
+
;;;###autoload
(defun thumbs-find-thumb (img)
"Display the thumbnail for IMG."
@@ -397,30 +362,28 @@ if MARKED is non-nil, the image is marked."
"Insert the thumbnail for IMG at point.
if MARKED is non-nil, the image is marked"
(thumbs-insert-image
- (thumbs-make-thumb img) 'jpeg thumbs-relief marked))
+ (thumbs-make-thumb img) 'jpeg thumbs-relief marked)
+ (put-text-property (1- (point)) (point)
+ 'thumb-image-file img))
(defun thumbs-do-thumbs-insertion (L)
"Insert all thumbs in list L."
- (setq thumbs-fileL nil)
(let ((i 0))
- (while L
+ (dolist (img L)
+ (thumbs-insert-thumb img
+ (member img thumbs-markedL))
(when (= 0 (mod (setq i (1+ i)) thumbs-per-line))
- (newline))
- (setq thumbs-fileL (cons (cons (point)
- (car L))
- thumbs-fileL))
- (thumbs-insert-thumb (car L)
- (member (car L) thumbs-markedL))
- (setq L (cdr L)))))
+ (newline)))
+ (unless (bobp) (newline))))
(defun thumbs-show-thumbs-list (L &optional buffer-name same-window)
+ (when (not (display-images-p))
+ (error "Images are not supported in this Emacs session"))
(funcall (if same-window 'switch-to-buffer 'pop-to-buffer)
(or buffer-name "*THUMB-View*"))
(let ((inhibit-read-only t))
(erase-buffer)
(thumbs-mode)
- (make-variable-buffer-local 'thumbs-fileL)
- (setq thumbs-fileL nil)
(thumbs-do-thumbs-insertion L)
(goto-char (point-min))
(setq thumbs-current-dir default-directory)
@@ -452,7 +415,7 @@ and SAME-WINDOW to show thumbs in the same window."
;;;###autoload
(defalias 'thumbs 'thumbs-show-all-from-dir)
-(defun thumbs-find-image (img L &optional num otherwin)
+(defun thumbs-find-image (img &optional num otherwin)
(funcall
(if otherwin 'switch-to-buffer-other-window 'switch-to-buffer)
(concat "*Image: " (file-name-nondirectory img) " - "
@@ -466,8 +429,6 @@ and SAME-WINDOW to show thumbs in the same window."
(make-variable-buffer-local 'thumbs-current-tmp-filename)
(make-variable-buffer-local 'thumbs-current-image-size)
(make-variable-buffer-local 'thumbs-image-num)
- (make-variable-buffer-local 'thumbs-fileL)
- (setq thumbs-fileL L)
(delete-region (point-min)(point-max))
(thumbs-insert-image img (thumbs-image-type img) 0)))
@@ -475,10 +436,8 @@ and SAME-WINDOW to show thumbs in the same window."
"Display image IMG for thumbnail at point.
use another window it OTHERWIN is t."
(interactive)
- (let* ((L thumbs-fileL)
- (n (point))
- (i (or img (cdr (assoc n L)))))
- (thumbs-find-image i L n otherwin)))
+ (let* ((i (or img (thumbs-current-image))))
+ (thumbs-find-image i (point) otherwin)))
(defun thumbs-find-image-at-point-other-window ()
"Display image for thumbnail at point in the preview buffer.
@@ -486,6 +445,12 @@ Open another window."
(interactive)
(thumbs-find-image-at-point nil t))
+(defun thumbs-mouse-find-image (event)
+ "Display image for thumbnail at mouse click EVENT."
+ (interactive "e")
+ (mouse-set-point event)
+ (thumbs-find-image-at-point))
+
(defun thumbs-call-setroot-command (img)
"Call the setroot program for IMG."
(run-hooks 'thumbs-before-setroot-hook)
@@ -494,11 +459,12 @@ Open another window."
(shell-quote-argument (expand-file-name img))
thumbs-setroot-command nil t))
(run-hooks 'thumbs-after-setroot-hook))
-
+
(defun thumbs-set-image-at-point-to-root-window ()
"Set the image at point as the desktop wallpaper."
(interactive)
- (thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL))))
+ (thumbs-call-setroot-command
+ (thumbs-current-image)))
(defun thumbs-set-root ()
"Set the current image as root."
@@ -507,78 +473,158 @@ Open another window."
(or thumbs-current-tmp-filename
thumbs-current-image-filename)))
+(defun thumbs-file-alist ()
+ "Make an alist of elements (POS . FILENAME) for all images in thumb buffer."
+ (save-excursion
+ (let (list)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (thumbs-current-image)
+ (push (cons (point-marker)
+ (thumbs-current-image))
+ list))
+ (forward-char 1))
+ list)))
+
+(defun thumbs-file-list ()
+ "Make a list of file names for all images in thumb buffer."
+ (save-excursion
+ (let (list)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (thumbs-current-image)
+ (push (thumbs-current-image) list))
+ (forward-char 1))
+ (nreverse list))))
+
(defun thumbs-delete-images ()
"Delete the image at point (and it's thumbnail) (or marked files if any)."
(interactive)
- (let ((f (or thumbs-markedL (list (cdr (assoc (point) thumbs-fileL))))))
- (if (yes-or-no-p "Really delete %d files?" (length f))
- (progn
- (mapcar (lambda (x)
- (setq thumbs-fileL (delete (rassoc x thumbs-fileL) thumbs-fileL))
+ (let ((files (or thumbs-markedL (list (thumbs-current-image)))))
+ (if (yes-or-no-p (format "Really delete %d files? " (length files)))
+ (let ((thumbs-fileL (thumbs-file-alist))
+ (inhibit-read-only t))
+ (dolist (x files)
+ (let (failure)
+ (condition-case ()
+ (progn
(delete-file x)
- (delete-file (thumbs-thumbname x))) f)
- (thumbs-redraw-buffer)))))
+ (delete-file (thumbs-thumbname x)))
+ (file-error (setq failure t)))
+ (unless failure
+ (when (rassoc x thumbs-fileL)
+ (goto-char (car (rassoc x thumbs-fileL)))
+ (delete-region (point) (1+ (point))))
+ (setq thumbs-markedL
+ (delq x thumbs-markedL)))))))))
+
+(defun thumbs-rename-images (newfile)
+ "Rename the image at point (and it's thumbnail) (or marked files if any)."
+ (interactive "FRename to file or directory: ")
+ (let ((files (or thumbs-markedL (list (thumbs-current-image))))
+ failures)
+ (if (and (not (file-directory-p newfile))
+ thumbs-markedL)
+ (if (file-exists-p newfile)
+ (error "Renaming marked files to file name `%s'" newfile)
+ (make-directory newfile t)))
+ (if (yes-or-no-p (format "Really rename %d files? " (length files)))
+ (let ((thumbs-fileL (thumbs-file-alist))
+ (inhibit-read-only t))
+ (dolist (file files)
+ (let (failure)
+ (condition-case ()
+ (if (file-directory-p newfile)
+ (rename-file file
+ (expand-file-name
+ (file-name-nondirectory file)
+ newfile))
+ (rename-file file newfile))
+ (file-error (setq failure t)
+ (push file failures)))
+ (unless failure
+ (when (rassoc file thumbs-fileL)
+ (goto-char (car (rassoc file thumbs-fileL)))
+ (delete-region (point) (1+ (point))))
+ (setq thumbs-markedL
+ (delq file thumbs-markedL)))))))
+ (if failures
+ (display-warning 'file-error
+ (format "Rename failures for %s into %s"
+ failures newfile)
+ :error))))
(defun thumbs-kill-buffer ()
"Kill the current buffer."
(interactive)
(let ((buffer (current-buffer)))
- (ignore-errors (delete-window (selected-window)))
+ (condition-case nil
+ (delete-window (selected-window))
+ (error nil))
(kill-buffer buffer)))
(defun thumbs-show-image-num (num)
"Show the image with number NUM."
- (let ((inhibit-read-only t))
- (delete-region (point-min)(point-max))
- (let ((i (cdr (assoc num thumbs-fileL))))
- (thumbs-insert-image i (thumbs-image-type i) 0)
- (sleep-for 2)
- (rename-buffer (concat "*Image: "
- (file-name-nondirectory i)
- " - "
- (number-to-string num) "*")))
- (setq thumbs-image-num num
- thumbs-current-image-filename i)))
+ (let ((image-buffer (get-buffer-create "*Image*")))
+ (let ((i (thumbs-current-image)))
+ (with-current-buffer image-buffer
+ (thumbs-insert-image i (thumbs-image-type i) 0))
+ (setq thumbs-image-num num
+ thumbs-current-image-filename i))))
(defun thumbs-next-image ()
"Show next image."
(interactive)
(let* ((i (1+ thumbs-image-num))
- (l (caar thumbs-fileL))
- (num
- (cond ((assoc i thumbs-fileL) i)
- ((>= i l) 1)
- (t (1+ i)))))
- (thumbs-show-image-num num)))
+ (list (thumbs-file-alist))
+ (l (caar list)))
+ (while (and (/= i thumbs-image-num) (not (assoc i list)))
+ (setq i (if (>= i l) 1 (1+ i))))
+ (thumbs-show-image-num i)))
(defun thumbs-previous-image ()
"Show the previous image."
(interactive)
(let* ((i (- thumbs-image-num 1))
- (l (caar thumbs-fileL))
- (num
- (cond ((assoc i thumbs-fileL) i)
- ((<= i 1) l)
- (t (- i 1)))))
- (thumbs-show-image-num num)))
+ (list (thumbs-file-alist))
+ (l (caar list)))
+ (while (and (/= i thumbs-image-num) (not (assoc i list)))
+ (setq i (if (<= i 1) l (1- i))))
+ (thumbs-show-image-num i)))
(defun thumbs-redraw-buffer ()
"Redraw the current thumbs buffer."
(let ((p (point))
- (inhibit-read-only t))
- (delete-region (point-min)(point-max))
- (thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL)))
- (goto-char (1+ p))))
-
+ (inhibit-read-only t)
+ (files (thumbs-file-list)))
+ (erase-buffer)
+ (thumbs-do-thumbs-insertion files)
+ (goto-char p)))
+
(defun thumbs-mark ()
"Mark the image at point."
(interactive)
- (setq thumbs-markedL (cons (cdr (assoc (point) thumbs-fileL)) thumbs-markedL))
- (let ((inhibit-read-only t))
- (delete-char 1)
- (thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL)) t))
- (when (eolp)(forward-char)))
-
+ (let ((elt (thumbs-current-image)))
+ (unless elt
+ (error "No image here"))
+ (push elt thumbs-markedL)
+ (let ((inhibit-read-only t))
+ (delete-char 1)
+ (thumbs-insert-thumb elt t)))
+ (when (eolp) (forward-char)))
+
+(defun thumbs-unmark ()
+ "Unmark the image at point."
+ (interactive)
+ (let ((elt (thumbs-current-image)))
+ (unless elt
+ (error "No image here"))
+ (setq thumbs-markedL (delete elt thumbs-markedL))
+ (let ((inhibit-read-only t))
+ (delete-char 1)
+ (thumbs-insert-thumb elt nil)))
+ (when (eolp) (forward-char)))
+
;; Image modification routines
(defun thumbs-modify-image (action &optional arg)
@@ -604,8 +650,8 @@ ACTION and ARG should be legal convert command."
(defun thumbs-emboss-image (emboss)
"Emboss the image with value EMBOSS."
(interactive "nEmboss value: ")
- (if (or (< emboss 3)(> emboss 31)(evenp emboss))
- (error "Arg must be a odd number between 3 and 31"))
+ (if (or (< emboss 3) (> emboss 31) (zerop (% emboss 2)))
+ (error "Arg must be an odd number between 3 and 31"))
(thumbs-modify-image "emboss" (number-to-string emboss)))
(defun thumbs-monochrome-image ()
@@ -628,17 +674,24 @@ ACTION and ARG should be legal convert command."
(interactive)
(thumbs-modify-image "rotate" "90"))
+(defun thumbs-current-image ()
+ "Return the name of the image file name at point."
+ (get-text-property (point) 'thumb-image-file))
+
(defun thumbs-forward-char ()
"Move forward one image."
(interactive)
(forward-char)
- (when (eolp)(forward-char))
+ (while (and (not (eobp)) (not (thumbs-current-image)))
+ (forward-char))
(thumbs-show-name))
(defun thumbs-backward-char ()
"Move backward one image."
(interactive)
(forward-char -1)
+ (while (and (not (bobp)) (not (thumbs-current-image)))
+ (forward-char -1))
(thumbs-show-name))
(defun thumbs-forward-line ()
@@ -656,15 +709,15 @@ ACTION and ARG should be legal convert command."
(defun thumbs-show-name ()
"Show the name of the current file."
(interactive)
- (let ((f (cdr (assoc (point) thumbs-fileL))))
- (message "%s [%s]" f (thumbs-file-size f))))
+ (let ((f (thumbs-current-image)))
+ (and f (message "%s [%s]" f (thumbs-file-size f)))))
(defun thumbs-save-current-image ()
"Save the current image."
(interactive)
(let ((f (or thumbs-current-tmp-filename
thumbs-current-image-filename))
- (sa (read-from-minibuffer "save file as: "
+ (sa (read-from-minibuffer "Save image file as: "
thumbs-current-image-filename)))
(copy-file f sa)))
@@ -678,6 +731,7 @@ ACTION and ARG should be legal convert command."
(defvar thumbs-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [return] 'thumbs-find-image-at-point)
+ (define-key map [mouse-2] 'thumbs-mouse-find-image)
(define-key map [(meta return)] 'thumbs-find-image-at-point-other-window)
(define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window)
(define-key map [delete] 'thumbs-delete-images)
@@ -687,15 +741,20 @@ ACTION and ARG should be legal convert command."
(define-key map [down] 'thumbs-forward-line)
(define-key map "d" 'thumbs-dired)
(define-key map "m" 'thumbs-mark)
+ (define-key map "u" 'thumbs-unmark)
+ (define-key map "R" 'thumbs-rename-images)
+ (define-key map "x" 'thumbs-delete-images)
(define-key map "s" 'thumbs-show-name)
(define-key map "q" 'thumbs-kill-buffer)
map)
"Keymap for `thumbs-mode'.")
+(put 'thumbs-mode 'mode-class 'special)
(define-derived-mode thumbs-mode
fundamental-mode "thumbs"
"Preview images in a thumbnails buffer"
(make-variable-buffer-local 'thumbs-markedL)
+ (setq buffer-read-only t)
(setq thumbs-markedL nil))
(defvar thumbs-view-image-mode-map
@@ -715,6 +774,7 @@ ACTION and ARG should be legal convert command."
"Keymap for `thumbs-view-image-mode'.")
;; thumbs-view-image-mode
+(put 'thumbs-view-image-mode 'mode-class 'special)
(define-derived-mode thumbs-view-image-mode
fundamental-mode "image-view-mode")
diff --git a/lisp/time-stamp.el b/lisp/time-stamp.el
index b6e76ee5394..f574144f4b0 100644
--- a/lisp/time-stamp.el
+++ b/lisp/time-stamp.el
@@ -5,7 +5,7 @@
;; This file is part of GNU Emacs.
-;; Maintainer's Time-stamp: <2003-02-01 09:26:25 gildea>
+;; Maintainer's Time-stamp: <2004-06-13 19:04:36 teirllm>
;; Maintainer: Stephen Gildea <gildea@stop.mail-abuse.org>
;; Keywords: tools
@@ -32,7 +32,7 @@
;; See the top of `time-stamp.el' for another example.
;; To use time-stamping, add this line to your .emacs file:
-;; (add-hook 'write-file-hooks 'time-stamp)
+;; (add-hook 'before-save-hook 'time-stamp)
;; Now any time-stamp templates in your files will be updated automatically.
;; See the documentation for the functions `time-stamp'
@@ -242,7 +242,8 @@ of the time-stamped file itself.")
"Update the time stamp string(s) in the buffer.
A template in a file can be automatically updated with a new time stamp
every time you save the file. Add this line to your .emacs file:
- (add-hook 'write-file-hooks 'time-stamp)
+ (add-hook 'before-save-hook 'time-stamp)
+or customize `before-save-hook' through Custom.
Normally the template must appear in the first 8 lines of a file and
look like one of the following:
Time-stamp: <>
@@ -318,7 +319,6 @@ template."
(setq start (time-stamp-once start search-limit ts-start ts-end
ts-format format-lines end-lines))
(setq ts-count (1- ts-count))))
- ;; be sure to return nil so can be used on write-file-hooks
nil)
(defun time-stamp-once (start search-limit ts-start ts-end
diff --git a/lisp/toolbar/README b/lisp/toolbar/README
new file mode 100644
index 00000000000..f7c8cb033b4
--- /dev/null
+++ b/lisp/toolbar/README
@@ -0,0 +1,8 @@
+The following icons are from GTK+ 2.x:
+
+ close.xpm copy.xpm cut.xpm help.xpm home.xpm
+ index.xpm jump_to.xpm left_arrow.xpm new.xpm open.xpm
+ paste.xpm preferences.xpm print.xpm right_arrow.xpm save.xpm
+ saveas.xpm search.xpm spell.xpm undo.xpm up_arrow.xpm
+
+They are not part of Emacs, but distributed and used by Emacs.
diff --git a/lisp/toolbar/alias.pbm b/lisp/toolbar/alias.pbm
index 1ebe932c6d4..239bd793002 100644
--- a/lisp/toolbar/alias.pbm
+++ b/lisp/toolbar/alias.pbm
Binary files differ
diff --git a/lisp/toolbar/close.pbm b/lisp/toolbar/close.pbm
index 04633c9d1d6..5229be27525 100644
--- a/lisp/toolbar/close.pbm
+++ b/lisp/toolbar/close.pbm
Binary files differ
diff --git a/lisp/toolbar/close.xpm b/lisp/toolbar/close.xpm
index ff364d57044..498843be6e2 100644
--- a/lisp/toolbar/close.xpm
+++ b/lisp/toolbar/close.xpm
@@ -1,32 +1,29 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
+static char * close_xpm[] = {
"24 24 2 1",
-" c Gray0",
-". c None",
-/* pixels */
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-"....... .... ..........",
-"....... .. .........",
-"........ . ..........",
-"........ ...........",
-"......... ............",
-"......... ...........",
-"........ ..........",
-"........ . .........",
-"....... ... ........",
-"....... ..... .........",
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-"........................"
-};
+" c None",
+". c #000000",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" . . ",
+" . ... ",
+" .. .... ",
+" .. ... ",
+" ..... ",
+" ... ",
+" ..... ",
+" ....... ",
+" ... .... ",
+" ... .... ",
+" ... .. ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/copy.pbm b/lisp/toolbar/copy.pbm
index 155be369266..abfd22f93b3 100644
--- a/lisp/toolbar/copy.pbm
+++ b/lisp/toolbar/copy.pbm
Binary files differ
diff --git a/lisp/toolbar/copy.xpm b/lisp/toolbar/copy.xpm
index 06efceae29d..6262a95bc39 100644
--- a/lisp/toolbar/copy.xpm
+++ b/lisp/toolbar/copy.xpm
@@ -1,37 +1,53 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 7 1",
-" c Gray0",
-". c #424242423a3a",
-"X c #68e968e96363",
-"o c #a8b1a8b1992b",
-"O c #d3d3d3d3bdbd",
-"+ c #e419e419cd6b",
-"@ c None",
-/* pixels */
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@ @@@@@@@@@@@@@@",
-"@@@@@@ Oo @@@@@@@@@@@@@",
-"@@@@ .ooOO @@@@ @@@@@@@",
-"@@@@ +XoOOo @ Oo @@@@@@",
-"@@@@ +.oO++ .ooOO @@@@@@",
-"@@@@ XoO+++ +XoOOo @@@@@",
-"@@@@ oOO+++ +.oO++ @@@@@",
-"@@@@ oO++++ XoOO++o @@@@",
-"@@@@@ +++++ oOO++++o @@@",
-"@@@@@ o++++ oO++++++ @@@",
-"@@@@@@ ++o +++++++o @@",
-"@@@@@@ o @@ o++++o @@@",
-"@@@@@@@ @@@@@ ++o @@@@@",
-"@@@@@@@@@@ @@ o @@@@@@@",
-"@@@@@@@ @@ @@@@@@@@@",
-"@@@@@@@ @@@@@@@@@@@@",
-"@@@@@@@@@@ @@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@"
-};
+static char * copy_xpm[] = {
+"24 24 26 1",
+" c None",
+". c #000000",
+"+ c #B4B4B4",
+"@ c #F8F8F8",
+"# c #F6F6F6",
+"$ c #C3C3C3",
+"% c #E9E9E9",
+"& c #989898",
+"* c #828282",
+"= c #8A8A8A",
+"- c #E8E8E8",
+"; c #636363",
+"> c #5A5A5A",
+", c #6B6B6B",
+"' c #B3B3B3",
+") c #FFFFFF",
+"! c #D6D6D6",
+"~ c #818181",
+"{ c #A7A7A7",
+"] c #8F8F8F",
+"^ c #C6C6C6",
+"/ c #808080",
+"( c #E7E7E7",
+"_ c #6D6D6D",
+": c #767676",
+"< c #F5F5F5",
+" ",
+" ............. ",
+" .+@@@@@@@@@#$. ",
+" .@%%%%%%%%%%%. ",
+" .@&**=%+*%*+%. ",
+" .@%%%%%%%%---. ",
+" .@;>%,*+-............ ",
+" .@%%%%%%.'))))))))))!. ",
+" .@&**%*~.)))))))))))). ",
+" .@%%%%%-.){]]&)^])]^). ",
+" .@;>>%,/.)))))))))))). ",
+" .@%%%%%(.)_;):]^)^])). ",
+" .@&**%*~.)))))))))))). ",
+" .<%%%%%-.){]])]]^)&]). ",
+" .$%%%%%-.)))))))))))). ",
+" ........)_;;):]^)^]). ",
+" .)))))))))))). ",
+" .){]])]]^)&]). ",
+" .)))))))))))). ",
+" .!))))))))))!. ",
+" .............. ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/cut.pbm b/lisp/toolbar/cut.pbm
index 570260767cb..29bf1abc073 100644
--- a/lisp/toolbar/cut.pbm
+++ b/lisp/toolbar/cut.pbm
Binary files differ
diff --git a/lisp/toolbar/cut.xpm b/lisp/toolbar/cut.xpm
index 563d64ec343..3f8e71d22ce 100644
--- a/lisp/toolbar/cut.xpm
+++ b/lisp/toolbar/cut.xpm
@@ -1,32 +1,67 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 2 1",
-" c Gray0",
-". c None",
-/* pixels */
-"........................",
-"........................",
-"........................",
-"........................",
-"........................",
-".................. .....",
-"................ ......",
-"............... .......",
-".............. ........",
-"............. .........",
-".... .... ..... ..",
-"... ... .. ... ....",
-"... ... ......",
-".... ... .........",
-".......... ............",
-"......... ............",
-"........ .. ............",
-"....... ... ............",
-"....... .. .............",
-"....... ..............",
-"........................",
-"........................",
-"........................",
-"........................"
-};
+static char * cut_xpm[] = {
+"24 24 40 1",
+" c None",
+". c #000000",
+"+ c #C9C7C2",
+"@ c #E6E4E0",
+"# c #EFEEED",
+"$ c #494946",
+"% c #73726E",
+"& c #F0EEED",
+"* c #7F7D75",
+"= c #F2F1EF",
+"- c #D2CFC8",
+"; c #E7E7E4",
+"> c #BAB5AB",
+", c #565653",
+"' c #EDECE9",
+") c #A4A097",
+"! c #817F7E",
+"~ c #4E4C48",
+"{ c #F6F5F4",
+"] c #474541",
+"^ c #EFEEEC",
+"/ c #8C8B8A",
+"( c #F3F2F0",
+"_ c #77746D",
+": c #323232",
+"< c #EBEBEA",
+"[ c #605D58",
+"} c #F5F4F3",
+"| c #CECCC7",
+"1 c #363634",
+"2 c #6F6E6D",
+"3 c #BEBDBB",
+"4 c #EAE7E4",
+"5 c #B8B5B1",
+"6 c #474747",
+"7 c #DAD8D4",
+"8 c #9B9996",
+"9 c #161615",
+"0 c #6D6B6A",
+"a c #3A3837",
+" ",
+" ",
+" . . ",
+" . . ",
+" .+. .@. ",
+" .#$ %@. ",
+" .&*. .=-. ",
+" .;>, %'). ",
+" !#*. .=-~ ",
+" .{>] ~^>. ",
+" /(_.:<-[ ",
+" .}|123>. ",
+" .456>. ",
+" .78.. ",
+" .90a. ",
+" ............. ",
+" . ... ... ... ",
+" .. .. .. .. ",
+" . . . . ",
+" .. .. .. .. ",
+" .... .. . ",
+" .... .... ",
+" ",
+" "};
diff --git a/lisp/toolbar/help.pbm b/lisp/toolbar/help.pbm
index 562cc6137b5..2575f6f2613 100644
--- a/lisp/toolbar/help.pbm
+++ b/lisp/toolbar/help.pbm
Binary files differ
diff --git a/lisp/toolbar/help.xpm b/lisp/toolbar/help.xpm
index bca0bf8e4fc..1d65ce03b53 100644
--- a/lisp/toolbar/help.xpm
+++ b/lisp/toolbar/help.xpm
@@ -1,36 +1,271 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 6 1",
-" c Gray0",
-". c #65658b8b5e5e",
-"X c #934ab2448dfb",
-"o c #b35dc8c8afaf",
-"O c #e0b2e944df83",
-"+ c None",
-/* pixels */
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"+++++++++ ++++++++++",
-"++++++++ oOOOO +++++++++",
-"+++++++ OOOOOOO ++++++++",
-"++++++ oOo oOo +++++++",
-"+++++++ O +++ OO +++++++",
-"+++++++O ++++ Oo +++++++",
-"++++++++++++ OO. +++++++",
-"+++++++++++ OOX ++++++++",
-"++++++++++ OOX +++++++++",
-"+++++++++ XOX ++++++++++",
-"+++++++++ OX +++++++++++",
-"+++++++++ +++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++ ++++++++++++",
-"+++++++++ Oo +++++++++++",
-"+++++++++ oX +++++++++++",
-"++++++++++ ++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++"
-};
+static char * help_xpm[] = {
+"24 24 244 2",
+" c None",
+". c #000000",
+"+ c #454442",
+"@ c #1D1D1C",
+"# c #040404",
+"$ c #1B1B1B",
+"% c #3D3C3A",
+"& c #4D4C4B",
+"* c #2F2F2D",
+"= c #C1BFBB",
+"- c #ECEAE7",
+"; c #F5F3F0",
+"> c #F2F0EC",
+", c #E1DFDC",
+"' c #AFADAA",
+") c #272726",
+"! c #020202",
+"~ c #3F3E3E",
+"{ c #36302D",
+"] c #181818",
+"^ c #FBF8F5",
+"/ c #FEFCF8",
+"( c #FAF8F5",
+"_ c #F5F4F1",
+": c #F2F1ED",
+"< c #F1EFEB",
+"[ c #F1EEEB",
+"} c #EAE9E6",
+"| c #DAD8D4",
+"1 c #100E0E",
+"2 c #1F100E",
+"3 c #AF3A1E",
+"4 c #FBAB93",
+"5 c #FAE9E3",
+"6 c #F0EFEB",
+"7 c #E9E8E5",
+"8 c #EAE8E6",
+"9 c #ECEAE8",
+"0 c #EDEBE9",
+"a c #EDEBE8",
+"b c #EACFC6",
+"c c #D5340A",
+"d c #751904",
+"e c #100806",
+"f c #34160D",
+"g c #AF3C20",
+"h c #FCCCBD",
+"i c #F7BEAD",
+"j c #E67554",
+"k c #DFDDDB",
+"l c #DBD9D6",
+"m c #D8D7D3",
+"n c #DBDAD6",
+"o c #E3E2DE",
+"p c #ECEBE8",
+"q c #E5572D",
+"r c #E33A0B",
+"s c #D4340A",
+"t c #691504",
+"u c #100504",
+"v c #582C22",
+"w c #0F0F0F",
+"x c #FDD4C8",
+"y c #F7BFAF",
+"z c #E87554",
+"A c #D5512B",
+"B c #C68270",
+"C c #BEBDBA",
+"D c #A5A3A0",
+"E c #9C9A95",
+"F c #B9B7B2",
+"G c #D7D6D2",
+"H c #E7E5E2",
+"I c #E79A85",
+"J c #E53C0B",
+"K c #E43C0B",
+"L c #E23A0B",
+"M c #C93009",
+"N c #010000",
+"O c #040100",
+"P c #FAB19C",
+"Q c #FACCBE",
+"R c #EB8264",
+"S c #D8532D",
+"T c #C0340F",
+"U c #932006",
+"V c #141412",
+"W c #857974",
+"X c #DA370B",
+"Y c #EC7C5B",
+"Z c #E95B32",
+"` c #DE380B",
+" . c #9D2306",
+".. c #626261",
+"+. c #FEF1ED",
+"@. c #F09479",
+"#. c #DC532B",
+"$. c #C0350F",
+"%. c #942006",
+"&. c #621404",
+"*. c #E2522B",
+"=. c #F2A690",
+"-. c #E74E21",
+";. c #E23B0B",
+">. c #C99181",
+",. c #454342",
+"'. c #E5E4E2",
+"). c #FCFBFA",
+"!. c #E2D8D3",
+"~. c #C34C2A",
+"{. c #B02B07",
+"]. c #9E2D12",
+"^. c #EF8D71",
+"/. c #F09B83",
+"(. c #EADDD7",
+"_. c #272724",
+":. c #F0EEEC",
+"<. c #F3F2EF",
+"[. c #D7D6D3",
+"}. c #BFBEBB",
+"|. c #9E6153",
+"1. c #3F0D02",
+"2. c #F0B9A9",
+"3. c #F6F5F4",
+"4. c #E8E7E4",
+"5. c #DAD8D5",
+"6. c #585652",
+"7. c #F6F4F0",
+"8. c #DAD8D6",
+"9. c #C2C1BE",
+"0. c #989691",
+"a. c #0A0A08",
+"b. c #F6F4F2",
+"c. c #F4F3F1",
+"d. c #E4E3E0",
+"e. c #D3D2CE",
+"f. c #63625D",
+"g. c #DCDAD8",
+"h. c #C7C6C2",
+"i. c #ABAAA5",
+"j. c #0A0A0A",
+"k. c #FAF8F6",
+"l. c #EFEDEA",
+"m. c #DDDCD8",
+"n. c #C6C4C2",
+"o. c #3E3E39",
+"p. c #1B1B19",
+"q. c #F0EEEA",
+"r. c #E0DFDD",
+"s. c #CCCBC9",
+"t. c #C0BFBB",
+"u. c #131311",
+"v. c #676663",
+"w. c #FCFAF8",
+"x. c #D6D4D2",
+"y. c #BCBAB7",
+"z. c #3C3C3A",
+"A. c #DEDCD9",
+"B. c #7E4B3E",
+"C. c #232323",
+"D. c #CC9385",
+"E. c #FAFAF7",
+"F. c #E6E6E2",
+"G. c #CDCCCA",
+"H. c #B0B0AC",
+"I. c #EDE3DF",
+"J. c #E78468",
+"K. c #DF5D3A",
+"L. c #631909",
+"M. c #282828",
+"N. c #B46E5E",
+"O. c #FCC3B2",
+"P. c #F1A691",
+"Q. c #DCD2CC",
+"R. c #C8C6C3",
+"S. c #7E7C78",
+"T. c #E8AD9C",
+"U. c #E96139",
+"V. c #EB7452",
+"W. c #EF8E72",
+"X. c #EA8063",
+"Y. c #9E2E13",
+"Z. c #3F1811",
+"`. c #121212",
+" + c #6B433B",
+".+ c #E0A191",
+"++ c #FDD3C7",
+"@+ c #F4AD98",
+"#+ c #DE532B",
+"$+ c #C83409",
+"%+ c #B48274",
+"&+ c #383534",
+"*+ c #D6340A",
+"=+ c #E43D0F",
+"-+ c #E8582E",
+";+ c #ED7957",
+">+ c #F4B6A4",
+",+ c #F4B09D",
+"'+ c #F0E5E0",
+")+ c #F4F3EF",
+"!+ c #FDF8F6",
+"~+ c #FBCEC1",
+"{+ c #F28B6E",
+"]+ c #E44E23",
+"^+ c #D3370A",
+"/+ c #BF2F09",
+"(+ c #260800",
+"_+ c #190F0B",
+":+ c #D5350A",
+"<+ c #E43D0C",
+"[+ c #E74C1F",
+"}+ c #EFBBAB",
+"|+ c #F5F4F3",
+"1+ c #F5F3F1",
+"2+ c #EAB1A0",
+"3+ c #DE4316",
+"4+ c #C5310A",
+"5+ c #591202",
+"6+ c #0E0504",
+"7+ c #C83009",
+"8+ c #E0532B",
+"9+ c #E7E6E3",
+"0+ c #E7E6E2",
+"a+ c #DDDCD9",
+"b+ c #CFCECA",
+"c+ c #C14724",
+"d+ c #AE2907",
+"e+ c #290800",
+"f+ c #0F0705",
+"g+ c #9B2205",
+"h+ c #C1A89F",
+"i+ c #D1D0CC",
+"j+ c #CFCDCA",
+"k+ c #C7C6C3",
+"l+ c #BBBAB7",
+"m+ c #B5B4B1",
+"n+ c #A7A6A2",
+"o+ c #66564F",
+"p+ c #0B0908",
+"q+ c #010100",
+"r+ c #222221",
+"s+ c #51504B",
+"t+ c #5D5C57",
+"u+ c #3B3B37",
+" . . + @ # # $ % ",
+" . . . . & # * = - ; > , ' ) ! ~ . . . . ",
+". . { ] ^ / ( _ : > < [ } | . 1 . . ",
+" . 2 3 4 5 6 - 7 8 9 0 0 a b c d e . ",
+" . f g h i j k l m n o } p a q r s t u . . ",
+" v w x y z A B C D E F G H I J K L M . N ",
+" O P Q R S T U . . . . V W X Y Z K ` .. ",
+" ..+.@.#.$.%.. . . &.*.=.-.;.>.! . ",
+",.'.).!.~.{.. . . ].^./.(.n _.. ",
+"@ :.<.[.}.|.. 1.2.3.4.5.6.. ",
+"# 7.6 8.9.0.. a.b.c.d.e.f.. ",
+"# > < g.h.i.. j.k.l.m.n.o.. ",
+"p., q.r.s.t.u. v.w.9 x.y.. . ",
+"z.' [ 7 A.[.B.. C.D.E.F.G.H.. . ",
+" ) } 0 I.J.K.L.. M.N.O.P.Q.R.S.. . ",
+" ! | T.U.V.W.X.Y.Z.a.`. +.+++@+#+$+%+. . ",
+" &+. *+=+-+;+>+,+'+)+k.!+~+{+]+^+/+(+. . ",
+" . _+d :+L <+[+}+|+l.1+|+2+3+^+4+5+. . . ",
+" . 6+t 7+` 8+9+0+o a+[.b+c+d+e+. . . ",
+" . f+. g+h+i+j+k+l+m+n+o+. . . . ",
+" . . . p+. q+r+s+t+u+. . . . . . . ",
+" . . . . . . . . . . . . ",
+" ",
+" "};
diff --git a/lisp/toolbar/home.pbm b/lisp/toolbar/home.pbm
index 117955f2a74..5be84460652 100644
--- a/lisp/toolbar/home.pbm
+++ b/lisp/toolbar/home.pbm
Binary files differ
diff --git a/lisp/toolbar/home.xpm b/lisp/toolbar/home.xpm
index 33d02aaf387..57e8f9cc25a 100644
--- a/lisp/toolbar/home.xpm
+++ b/lisp/toolbar/home.xpm
@@ -1,36 +1,128 @@
/* XPM */
static char * home_xpm[] = {
-"24 24 9 1",
-" c None",
-". c #020202",
-"+ c #6C7962",
-"@ c #7A8A6E",
-"# c #FEFEFE",
-"$ c #7E8E76",
-"% c #82927A",
-"& c #C8CEC4",
-"* c #E3E7E1",
-" ",
-" ",
-" ",
-" ",
-" . ... ",
-" .#. .&. ",
-" .#*%..&. ",
-" .##&&$.&. ",
-" .##&&&&$&. ",
-" .*#&&&&&&@. ",
-" .##&&&&&&&&+. ",
-" .###&&&&&&&&&+. ",
-" ...##&&&&&&&&+... ",
-" .##&&&&&&&&+. ",
-" .##....&&&&+. ",
-" .##.&&.&&&&+. ",
-" .##.&&.&&&&+. ",
-" .#*.&&.&&&&+. ",
-" .&+.++.+++++. ",
-" ............. ",
-" ",
-" ",
-" ",
-" "};
+"24 24 101 2",
+" c None",
+". c #000000",
+"+ c #212121",
+"@ c #2C2C2C",
+"# c #C1665A",
+"$ c #924B37",
+"% c #2A2A2A",
+"& c #333333",
+"* c #343434",
+"= c #242424",
+"- c #944D3A",
+"; c #A05443",
+"> c #181818",
+", c #474747",
+"' c #555555",
+") c #8D8D8D",
+"! c #383838",
+"~ c #191919",
+"{ c #974F3C",
+"] c #222222",
+"^ c #313131",
+"/ c #A1A1A1",
+"( c #676767",
+"_ c #ACACAC",
+": c #BCBCBC",
+"< c #585858",
+"[ c #141414",
+"} c #1C1C1C",
+"| c #464646",
+"1 c #666666",
+"2 c #BABABA",
+"3 c #7E7E7E",
+"4 c #D2D2D2",
+"5 c #FFFFFF",
+"6 c #4F4F4F",
+"7 c #262626",
+"8 c #232323",
+"9 c #505050",
+"0 c #B2B2B2",
+"a c #909090",
+"b c #9A9A9A",
+"c c #838383",
+"d c #171717",
+"e c #202020",
+"f c #717171",
+"g c #A6A6A6",
+"h c #616161",
+"i c #1D1D1D",
+"j c #1F1F1F",
+"k c #C4C4C4",
+"l c #CACACA",
+"m c #AEAEAE",
+"n c #D1D1D1",
+"o c #7C7C7C",
+"p c #BFBFBF",
+"q c #6C6C6C",
+"r c #EEEEEE",
+"s c #949494",
+"t c #C7C7C7",
+"u c #EBEBEB",
+"v c #7D7D7D",
+"w c #6E6E6E",
+"x c #A9A9A9",
+"y c #E99E8F",
+"z c #DD806D",
+"A c #9B5343",
+"B c #CECECE",
+"C c #626262",
+"D c #858585",
+"E c #ECA292",
+"F c #D0533A",
+"G c #934F3E",
+"H c #6D6D6D",
+"I c #ECA291",
+"J c #CF543C",
+"K c #371D16",
+"L c #5D5D5D",
+"M c #868686",
+"N c #787878",
+"O c #ECA696",
+"P c #C95C49",
+"Q c #E17C66",
+"R c #924E3D",
+"S c #888888",
+"T c #A0A0A0",
+"U c #3D1208",
+"V c #D15137",
+"W c #919191",
+"X c #879981",
+"Y c #82947C",
+"Z c #8A9B85",
+"` c #6E8467",
+" . c #5D7555",
+".. c #4C6042",
+"+. c #3F4F37",
+"@. c #303D2A",
+"#. c #7F8F7A",
+"$. c #64785E",
+"%. c #44563E",
+"&. c #657460",
+"*. c #40503A",
+" ",
+" . . ",
+" . . . . . + @ . ",
+" . # $ . . % & * = . ",
+" . - ; . > , ' ) ! ~ . ",
+" . { . ] ^ / ( _ : < [ . ",
+" . . } | 1 2 3 4 : 5 6 7 . ",
+" . 8 9 0 a 4 b 5 : 5 : c d . ",
+" . e f g 4 b 5 : 5 : 5 : 5 h i . ",
+" . j k k l 5 m 5 2 5 2 5 : 5 n o } . ",
+" . 8 m p p p p p p p p . . . . . a q = . ",
+" . . . . r 5 5 5 5 5 5 5 . s t u . v . . . . ",
+" . 4 5 . . . . . 5 . : 5 5 . w . ",
+" . x 5 . y z A . 5 . B 5 5 . C . ",
+" . D 5 . E F G . 5 . . . . . H . ",
+" . . 5 . I J K . k s L L M N . . ",
+" . . r . O P G . 5 5 5 5 5 2 . ",
+" . 2 . Q # R . : : : : : S . ",
+" . T U V # A . 5 5 5 5 5 W . ",
+" . . . . . . . . . . . . . . . . . . . . . ",
+" } X Y Z X ` ...+.@.. Y #.$.%.&.*.. ",
+" . . . . . . . . . . . . . . . . . ",
+" . . . ",
+" "};
diff --git a/lisp/toolbar/index.pbm b/lisp/toolbar/index.pbm
index 5411d49f071..d8aa08a7e53 100644
--- a/lisp/toolbar/index.pbm
+++ b/lisp/toolbar/index.pbm
Binary files differ
diff --git a/lisp/toolbar/index.xpm b/lisp/toolbar/index.xpm
index 154e4286083..7e1de12121b 100644
--- a/lisp/toolbar/index.xpm
+++ b/lisp/toolbar/index.xpm
@@ -1,39 +1,201 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 9 1",
-" c Gray0",
-". c #4646424233b4",
-"X c #6f4d67895151",
-"o c #911b871c69df",
-"O c #b3d8a9b58836",
-"+ c #c280b9779c39",
-"@ c #cd0cc646ae2e",
-"# c #e0e0e4e4e0e0",
-"$ c None",
-/* pixels */
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$ $$",
-"$$$$ ################ $$",
-"$$$$ ##### O######## $$",
-"$$$$ #### oX O####### $$",
-"$$$$ @o $$",
-"$$$$ #### @o O####### $$",
-"$$$$ #### @o O##### $$",
-"$$$$ #### @o X. O## $$",
-"$$$$ +o OX oX $$",
-"$$$$ ## X +o Oo Oo oX $$",
-"$$$$ ## o +OoOOoOOOOo $$",
-"$$$$ ## O +++OOOOOOOX $$",
-"$$$$ O O++O+OOOOOX $$",
-"$$$$ ## ooO+++O+OOOOX $$",
-"$$$$ ### oO++++OOOOo. $$",
-"$$$$ ### XOO++O+OOOo $$$",
-"$$$$ o++++OOOoX $$$",
-"$$$$$$$$$ XOO+++OOoX $$$",
-"$$$$$$$$$$ oO++OOOX $$$$",
-"$$$$$$$$$$$ OO++OOX $$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$"
-};
+static char * index_xpm[] = {
+"24 24 174 2",
+" c None",
+". c #000000",
+"+ c #FDFDFD",
+"@ c #F5F5F5",
+"# c #F6F6F6",
+"$ c #D0D0D0",
+"% c #C1C1C1",
+"& c #C3C3C3",
+"* c #C6C6C6",
+"= c #C8C8C8",
+"- c #8D8D8D",
+"; c #CACACA",
+"> c #919191",
+", c #EFEFEF",
+"' c #878787",
+") c #8A8A8A",
+"! c #5C5C5C",
+"~ c #F8F8F8",
+"{ c #EAEAEA",
+"] c #CCCCCC",
+"^ c #CECECE",
+"/ c #979797",
+"( c #CDCDCD",
+"_ c #A1A1A1",
+": c #090600",
+"< c #A3A3A3",
+"[ c #C5C5C5",
+"} c #C4C4C4",
+"| c #D1D1D1",
+"1 c #D2D2D1",
+"2 c #D2D2D2",
+"3 c #9A9A9A",
+"4 c #E8E8E8",
+"5 c #949494",
+"6 c #939393",
+"7 c #574F4F",
+"8 c #FDFDFC",
+"9 c #777777",
+"0 c #7E7E7E",
+"a c #9D9D9D",
+"b c #6B6B6B",
+"c c #F1F1F1",
+"d c #ECECEC",
+"e c #CFCFCF",
+"f c #575050",
+"g c #FDFAF8",
+"h c #A5A5A5",
+"i c #B9B9B9",
+"j c #EEEEEE",
+"k c #EDEDED",
+"l c #D5D5D5",
+"m c #BABABA",
+"n c #6D6767",
+"o c #F9F1EA",
+"p c #9E9E9E",
+"q c #B5B5B5",
+"r c #D9D9D9",
+"s c #D7D7D7",
+"t c #BCBCBC",
+"u c #625C5B",
+"v c #F9EEE4",
+"w c #4F4D4A",
+"x c #646464",
+"y c #747474",
+"z c #D6D6D5",
+"A c #DFDFDF",
+"B c #A0A0A0",
+"C c #615C5B",
+"D c #F9F0E4",
+"E c #746C67",
+"F c #FEFDFC",
+"G c #FFFEFD",
+"H c #131210",
+"I c #636363",
+"J c #7C7C7C",
+"K c #F3F2F2",
+"L c #98948F",
+"M c #F9EFE3",
+"N c #A09489",
+"O c #FEFDFD",
+"P c #766D68",
+"Q c #736961",
+"R c #A3A3A2",
+"S c #A6A6A6",
+"T c #DBDBDB",
+"U c #C7C7C7",
+"V c #E8E5E2",
+"W c #97938E",
+"X c #F6E9D8",
+"Y c #84817A",
+"Z c #FBF3EA",
+"` c #908C86",
+" . c #F1EDE7",
+".. c #7B7975",
+"+. c #878786",
+"@. c #070000",
+"#. c #FAFAFA",
+"$. c #DDDDDD",
+"%. c #E2DFDC",
+"&. c #A8A199",
+"*. c #F0E0CE",
+"=. c #C8BFB4",
+"-. c #D5CCBF",
+";. c #DFD7CD",
+">. c #DAD3C9",
+",. c #DDCFC4",
+"'. c #928C84",
+"). c #A8A8A8",
+"!. c #959595",
+"~. c #040000",
+"{. c #D9D5D2",
+"]. c #D9CABB",
+"^. c #D7C8B8",
+"/. c #DECFBF",
+"(. c #D8C9B9",
+"_. c #E3D3C2",
+":. c #C9BBAC",
+"<. c #D9CEC2",
+"[. c #7F766D",
+"}. c #909090",
+"|. c #D3D3D3",
+"1. c #060100",
+"2. c #C0BDBA",
+"3. c #8C8782",
+"4. c #C2B5A7",
+"5. c #BFB4A6",
+"6. c #B8AB9D",
+"7. c #BAAD9E",
+"8. c #BEB0A2",
+"9. c #948A7F",
+"0. c #716860",
+"a. c #E2E2E2",
+"b. c #A9A9A8",
+"c. c #332C2B",
+"d. c #5D5954",
+"e. c #79736C",
+"f. c #958C80",
+"g. c #8D8379",
+"h. c #988D82",
+"i. c #706760",
+"j. c #787878",
+"k. c #E4E4E4",
+"l. c #C2C2C2",
+"m. c #201A1A",
+"n. c #57514F",
+"o. c #625C59",
+"p. c #625A53",
+"q. c #6B625A",
+"r. c #585251",
+"s. c #696764",
+"t. c #080000",
+"u. c #989898",
+"v. c #B0B0B0",
+"w. c #AFAFAF",
+"x. c #999999",
+"y. c #9D9897",
+"z. c #050000",
+"A. c #0C0303",
+"B. c #080100",
+"C. c #030000",
+"D. c #282523",
+"E. c #5A5A5A",
+"F. c #868686",
+"G. c #ECE4E2",
+"H. c #DED7D5",
+"I. c #D8D1D0",
+"J. c #E0DBD7",
+"K. c #E9E6E3",
+"L. c #FCFBFA",
+"M. c #030500",
+"N. c #0B0505",
+"O. c #14100F",
+"P. c #090806",
+"Q. c #000100",
+" ",
+" . . . . . . . . . . . . . . . . . . . . ",
+" . + @ @ @ @ @ @ @ # # # # # # # # # $ . ",
+" . @ % % % & & & & * * * * * = = = = - . ",
+" . # & & & * * * * = = = = = ; ; ; ; > . ",
+" . , ' ' ' ) ) ) ) - - - - - > > > > ! . ",
+" . ~ { { { { { { { { { { { { { { { { ; . ",
+" . # ; ; ; ] ] ] ] ] ^ ^ ^ ^ $ $ $ $ / . ",
+" . # ] ] ] ( ^ ^ ^ _ : < [ } | 1 | 2 3 . ",
+" . 4 5 5 5 / / / 6 7 8 . 9 0 - a a a b . ",
+" . ~ c d d d d d e f g . h i $ j j k * . ",
+" . ~ 2 2 2 2 l l m n o . > p q r r r < . ",
+" . ~ l l l l s s t u v w . x . y p z < . ",
+" . A B B B B < 9 . C D E F . G H . I J . ",
+" . ~ @ , , , j . K L M N O P F Q R . S . ",
+" . ~ T T T T U . V W X Y Z ` ...+.@.< . ",
+" . #.$.$.$.$.& . %.&.*.=.-.;.>.,.'.@.p . ",
+" . { ).).).).!.~.{.].^./.(._.:.<.[.@.}.. ",
+" . #.@ c c c |.1.2.3.4.5.6.7.8.9.0.@.] . ",
+" . #.a.a.a.a.l b.c.d.e.f.g.9.h.i.. j.q . ",
+" . #.a.a.a.a.k.l.j.m.n.o.p.q.r.s.t.u.q . ",
+" . a.v.v.v.v.v.w.x.y.z.A.t.B.C.D.E.F.m . ",
+" . . . . . . . . . ~.G.H.I.J.K.L.M.. . . ",
+" ~.N.z.O.C.P.. Q. "};
diff --git a/lisp/toolbar/jump_to.pbm b/lisp/toolbar/jump_to.pbm
index effcdcc8bfd..5f5921baf57 100644
--- a/lisp/toolbar/jump_to.pbm
+++ b/lisp/toolbar/jump_to.pbm
Binary files differ
diff --git a/lisp/toolbar/jump_to.xpm b/lisp/toolbar/jump_to.xpm
index 2106d015285..8f9897974ab 100644
--- a/lisp/toolbar/jump_to.xpm
+++ b/lisp/toolbar/jump_to.xpm
@@ -1,39 +1,171 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 9 1",
-" c #011b011b011b",
-". c #5e0868be52d3",
-"X c #7c7c8b8b6e6e",
-"o c #8d4d97577838",
-"O c #ae51c17b9b26",
-"+ c #cedcabd6996e",
-"@ c #d305cecebaba",
-"# c #e38de39ed709",
-"$ c None",
-/* pixels */
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$ $$$$$$$$",
-"$$$$$$$$$$$ #@+ $$$$$$",
-"$$$$$$$$$$$ ###@+ $$$$$$",
-"$$$$$$$ #+++ $$$$$",
-"$$$$$$$ o@##O ++++ $$$$$",
-"$$$$$$$$ .OO. +++o $$$$$",
-"$$$$$$ #@O.. +++ $$$$$$",
-"$$$$ #@@Oo.. ++ $$$$$$",
-"$$$ #@@OOo. . $$$$$$$$",
-"$$$$ #OOO. $ $$$$$$$$$$",
-"$$$$$ #OX. $$$$$$$$$$$$$",
-"$$$$$$ O. $$$$$$$$$$$$$$",
-"$$$$$$$ . $$$$$$$$$$$$$$",
-"$$$$$$$$ $$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$",
-"$$$$$$$$$$$$$$$$$$$$$$$$"
-};
+static char * jump_to_xpm[] = {
+"24 24 144 2",
+" c None",
+". c #000000",
+"+ c #9ABC82",
+"@ c #C1E3AA",
+"# c #A0C487",
+"$ c #8F6508",
+"% c #AD671D",
+"& c #D6AF41",
+"* c #E1B744",
+"= c #B86F20",
+"- c #7E5907",
+"; c #D8E7CD",
+"> c #D9E7CF",
+", c #DDEAD2",
+"' c #E4EFDA",
+") c #EBF6DF",
+"! c #C8EBB0",
+"~ c #A2C688",
+"{ c #986F26",
+"] c #E2B946",
+"^ c #EFCD64",
+"/ c #F4D268",
+"( c #F6D469",
+"_ c #E7C24A",
+": c #D5B044",
+"< c #BC8C31",
+"[ c #1A0700",
+"} c #D7E6CD",
+"| c #B2D29C",
+"1 c #B6D69F",
+"2 c #BDDEA5",
+"3 c #C4E7AC",
+"4 c #CAEEB1",
+"5 c #A1C387",
+"6 c #CBB86E",
+"7 c #EDD97E",
+"8 c #FEE882",
+"9 c #FEE77E",
+"0 c #FDDF60",
+"a c #FBD14F",
+"b c #E4BF49",
+"c c #BB8C31",
+"d c #CFE2C3",
+"e c #B2D19C",
+"f c #B5D59F",
+"g c #BBDBA4",
+"h c #C1E3A9",
+"i c #C6E9AE",
+"j c #C3E6AB",
+"k c #A9CE8D",
+"l c #DCBA5C",
+"m c #FBE46B",
+"n c #FFEB64",
+"o c #FFE054",
+"p c #FED952",
+"q c #F8CF4E",
+"r c #C4A13E",
+"s c #8BA27B",
+"t c #618249",
+"u c #628349",
+"v c #64864B",
+"w c #66894D",
+"x c #688B4E",
+"y c #678B4D",
+"z c #6B9251",
+"A c #719755",
+"B c #55833A",
+"C c #ECC75E",
+"D c #FFED59",
+"E c #FFE757",
+"F c #FFDF54",
+"G c #FBD44F",
+"H c #E1BD48",
+"I c #B36C1F",
+"J c #608148",
+"K c #628449",
+"L c #63854A",
+"M c #65894C",
+"N c #6C9151",
+"O c #527E39",
+"P c #B39237",
+"Q c #F0C248",
+"R c #FFF25B",
+"S c #FFEB58",
+"T c #FFE155",
+"U c #FBD450",
+"V c #E3BD49",
+"W c #BC983B",
+"X c #618349",
+"Y c #628549",
+"Z c #65884B",
+"` c #4D7735",
+" . c #907934",
+".. c #DCB444",
+"+. c #FCDB52",
+"@. c #FFEF5A",
+"#. c #FFE957",
+"$. c #FEDF54",
+"%. c #F9D24F",
+"&. c #E0BA48",
+"*. c #B08F37",
+"=. c #52743B",
+"-. c #456A2F",
+";. c #608248",
+">. c #628448",
+",. c #476F31",
+"'. c #7F6B32",
+"). c #D0AF4B",
+"!. c #F5CF4E",
+"~. c #FFE255",
+"{. c #FEDA52",
+"]. c #EAC54B",
+"^. c #D0AC42",
+"/. c #9C5D1A",
+"(. c #5A7B42",
+"_. c #456C2F",
+":. c #6F5C23",
+"<. c #A78833",
+"[. c #F0C54A",
+"}. c #FFDA52",
+"|. c #FFDE53",
+"1. c #C39032",
+"2. c #886423",
+"3. c #BC9D3B",
+"4. c #F0C84E",
+"5. c #FFD551",
+"6. c #FED751",
+"7. c #FDD550",
+"8. c #EDC74C",
+"9. c #E5BF49",
+"0. c #CCA941",
+"a. c #AB7727",
+"b. c #B1822D",
+"c. c #DCB746",
+"d. c #DFBA47",
+"e. c #EDC64C",
+"f. c #E9C34B",
+"g. c #D6B144",
+"h. c #C19D3D",
+"i. c #AB7C2B",
+"j. c #BC7222",
+"k. c #BB983B",
+"l. c #B09638",
+"m. c #A2621B",
+" ",
+" ",
+" . ",
+" . . ",
+" . + . . . . . . . ",
+" . . . . . . @ # . . $ % & * = - . . ",
+" . ; > , ' ) ! ! ~ . { ] ^ / ( _ : < [ . ",
+" . } | 1 2 3 4 4 3 5 . 6 7 8 9 0 a b c . ",
+" . d e f g h i i h j k . l m n o p q r - . ",
+" . s t u v w x x y z A B . C D E F G H I . ",
+" . s J t K L v v M N O . P Q R S T U V W . ",
+" . s J J t X u Y Z ` . ...+.@.#.$.%.&.*.. ",
+" . =.-.-.-.-.;.>.,.. '.).!.E E ~.{.].^./.. ",
+" . . . . . . (._.. :.<.[.}.|.|.{.%.V 1.$ . ",
+" . -.. . 2.3.4.5.6.7.8.9.0.a.. ",
+" . . . . b.c.d.e.f.g.h.i.. . ",
+" . . $ j.k.l.m.$ . . ",
+" . . . . . . ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-copy.xpm b/lisp/toolbar/lc-copy.xpm
new file mode 100644
index 00000000000..f50fb51baf5
--- /dev/null
+++ b/lisp/toolbar/lc-copy.xpm
@@ -0,0 +1,33 @@
+/* XPM */
+static char * copy2_xpm[] = {
+"24 24 6 1",
+" c None",
+". c #FFFFFF",
+"+ c #000100",
+"@ c #6B6B66",
+"# c #BBBDBA",
+"$ c #504D46",
+" ",
+" +++++++++++++ ",
+" +#..........#+ ",
+" +............+ ",
+" +.#@@@.#@.@#.+ ",
+" +............+ ",
+" +.@$.@@#.++++++++++++ ",
+" +.......+#..........#+ ",
+" +.#@@.@@+............+ ",
+" +.......+.#@@#.#@.@#.+ ",
+" +.@$$.@@+............+ ",
+" +.......+.@@.@@#.#@..+ ",
+" +.#@@.@@+............+ ",
+" +.......+.#@@.@@#.#@.+ ",
+" +#......+............+ ",
+" ++++++++.@@@.@@#.#@.+ ",
+" +............+ ",
+" +.#@@.@@#.#@.+ ",
+" +............+ ",
+" +#..........#+ ",
+" ++++++++++++++ ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-cut.xpm b/lisp/toolbar/lc-cut.xpm
new file mode 100644
index 00000000000..750ec729f60
--- /dev/null
+++ b/lisp/toolbar/lc-cut.xpm
@@ -0,0 +1,34 @@
+/* XPM */
+static char * cut2_xpm[] = {
+"24 24 7 1",
+" c None",
+". c #000100",
+"+ c #BBBDBA",
+"@ c #FFFFFF",
+"# c #6B6B66",
+"$ c #504D46",
+"% c #3E4850",
+" ",
+" ",
+" . . ",
+" . . ",
+" .+. .@. ",
+" .@$ #@. ",
+" .@#. .@+. ",
+" .@+$ #@+. ",
+" #@#. .@+$ ",
+" .@+$ $@+. ",
+" #@#.%@+# ",
+" .@+$#++. ",
+" .@+$+. ",
+" .++.. ",
+" ..#$. ",
+" ............. ",
+" . ... ... ... ",
+" .. .. .. .. ",
+" . . . . ",
+" .. .. .. .. ",
+" .... .. . ",
+" .... .... ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-help.xpm b/lisp/toolbar/lc-help.xpm
new file mode 100644
index 00000000000..663460c3a06
--- /dev/null
+++ b/lisp/toolbar/lc-help.xpm
@@ -0,0 +1,39 @@
+/* XPM */
+static char * help2_xpm[] = {
+"24 24 12 1",
+" c None",
+". c #000100",
+"+ c #FFFFFF",
+"@ c #BBBDBA",
+"# c #C43107",
+"$ c #EBA291",
+"% c #D15237",
+"& c #504D46",
+"* c #751805",
+"= c #6B6B66",
+"- c #974F3D",
+"; c #3E4850",
+" .. &....& ",
+" ....&.;@++++@..&.... ",
+".. &.+++++++++@.. .. ",
+" . .%$+++++++++@#*. . ",
+" ..%$$%+@@@++++###*... ",
+" -.$$%%$@@@@@+$####.. ",
+" .$$$%#*.....=#%####. ",
+" =+$%#*.. .*#$##$.. ",
+"&++@%#.. .*$$+@.. ",
+".++@@-. *$++@&. ",
+".++@@@. .+++@=. ",
+".++@@@. .++@@&. ",
+".+++@@. =++@@.. ",
+"&@++@@-. .$++@@.. ",
+" .+++$%*. .-$$@@=.. ",
+" .@$%%$%*...&$$$%#$.. ",
+" &.###%$$++++$$###... ",
+" ..*####$++++$###*... ",
+" . .*###+++@@@%#... . ",
+" . ..#@@@@@@@&... . ",
+" .......&&&..... .. ",
+" ........ .... ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-home.xpm b/lisp/toolbar/lc-home.xpm
new file mode 100644
index 00000000000..c7a7ecfb634
--- /dev/null
+++ b/lisp/toolbar/lc-home.xpm
@@ -0,0 +1,38 @@
+/* XPM */
+static char * home2_xpm[] = {
+"24 24 11 1",
+" c None",
+". c #000100",
+"+ c #BBBDBA",
+"@ c #FFFFFF",
+"# c #6B6B66",
+"$ c #504D46",
+"% c #974F3D",
+"& c #EBA291",
+"* c #87AF85",
+"= c #3E4850",
+"- c #D15237",
+" ",
+" .. ",
+" .... ..=. ",
+" .%%..===.. ",
+" .%%..$$#$.. ",
+" .%..=+#++$.. ",
+" ...$#+#++@$.. ",
+" ..$+#++@+@+#.. ",
+" ..#+++@+@+@+@#.. ",
+" ..+++@+@+@+@+@+#.. ",
+" ..+++++++++.....##.. ",
+" ....@@@@@@@@.++@.#.... ",
+" .+@.....@.+@@.#. ",
+" .+@.&&%.@.+@@.#. ",
+" .#@.&-%.@.....#. ",
+" ..@.&-..++####.. ",
+" ..@.&-%.@@@@@+. ",
+" .+.&%%.+++++#. ",
+" .+.-%%.@@@@@#. ",
+" .................... . ",
+" .****##$$$.**#$#$. ",
+" .. ......... ...... ",
+" ... ",
+" "};
diff --git a/lisp/toolbar/lc-index.xpm b/lisp/toolbar/lc-index.xpm
new file mode 100644
index 00000000000..7a2464f032b
--- /dev/null
+++ b/lisp/toolbar/lc-index.xpm
@@ -0,0 +1,34 @@
+/* XPM */
+static char * index2_xpm[] = {
+"24 24 7 1",
+" c None",
+". c #BBBDBA",
+"+ c #000100",
+"@ c #FFFFFF",
+"# c #6B6B66",
+"$ c #504D46",
+"% c #3E4850",
+" ",
+" ++++++++++++++++++++ ",
+" +@@@@@@@@@@@@@@@@@.+ ",
+" +@................#+ ",
+" +@................#+ ",
+" +@#################+ ",
+" +@@@@@@@@@@@@@@@@@.+ ",
+" +@.................+ ",
+" +@........+........+ ",
+" +@.......$@+###...#+ ",
+" +@@@@@@@.$@+...@@@.+ ",
+" +@.......#@+#......+ ",
+" +@.......#@$+#+#...+ ",
+" +@.....#+#@#@+@++##+ ",
+" +@@@@@@+@.@.@#@#.+.+ ",
+" +@.....+@.@#@#@##+.+ ",
+" +@.....+@.@.....#+.+ ",
+" +@.....+........#+#+ ",
+" +@@@@@.+.#.....##+.+ ",
+" +@@@@@..%$######+#.+ ",
+" +@@@@@@.#+$#$#$#+..+ ",
+" +@........++++++$#.+ ",
+" ++++++++++@...@@++++ ",
+" ++++++++ "};
diff --git a/lisp/toolbar/lc-jump_to.xpm b/lisp/toolbar/lc-jump_to.xpm
new file mode 100644
index 00000000000..cd7499396c7
--- /dev/null
+++ b/lisp/toolbar/lc-jump_to.xpm
@@ -0,0 +1,35 @@
+/* XPM */
+static char * jump_to2_xpm[] = {
+"24 24 8 1",
+" c None",
+". c #D3B354",
+"+ c #000100",
+"@ c #87AF85",
+"# c #974F3D",
+"$ c #FFFFFF",
+"% c #D15237",
+"& c #BBBDBA",
+" ",
+" ",
+" + ",
+" ++ ",
+" +@+ ++++++ ",
+" ++++++@@+ +.#..%#++ ",
+" +$$$$$@@@+........++ ",
+" +&@@@@@@@@+........+ ",
+" +&@@@@@@@@@+.......#+ ",
+" +@@@@@@@@@@@+......%+ ",
+" +@@@@@@@@@@+........+ ",
+" +@@@@@@@@@+.........+ ",
+" +@@@@@@@@+#........#+ ",
+" ++++++@@+#..........+ ",
+" +@++#.........+ ",
+" ++ ++........++ ",
+" + +.%..#.++ ",
+" ++++++ ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-left_arrow.xpm b/lisp/toolbar/lc-left_arrow.xpm
new file mode 100644
index 00000000000..61dded3a5aa
--- /dev/null
+++ b/lisp/toolbar/lc-left_arrow.xpm
@@ -0,0 +1,34 @@
+/* XPM */
+static char * left_arrow2_xpm[] = {
+"24 24 7 1",
+" c None",
+". c #87AF85",
+"+ c #000100",
+"@ c #BBBDBA",
+"# c #504D46",
+"$ c #6B6B66",
+"% c #3E4850",
+" ",
+" ",
+" ",
+" + ",
+" ++ ",
+" +@+ ",
+" +@@+ ",
+" +@@@++++++++ ",
+" +@@@@@@@@@@.+ ",
+" +@.@@@@...@.$+ ",
+" %@.@@@..@@@@..+ ",
+" +@............$+ ",
+" +#...........#+ ",
+" +#..........#+ ",
+" +#..########+ ",
+" +#.#++++++++ ",
+" +##+ ",
+" +#+ ",
+" ++ ",
+" + ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-new.xpm b/lisp/toolbar/lc-new.xpm
new file mode 100644
index 00000000000..e2984bffd4f
--- /dev/null
+++ b/lisp/toolbar/lc-new.xpm
@@ -0,0 +1,33 @@
+/* XPM */
+static char * new2_xpm[] = {
+"24 24 6 1",
+" c None",
+". c #FFFFFF",
+"+ c #BBBDBA",
+"@ c #000100",
+"# c #6B6B66",
+"$ c #504D46",
+" ",
+" @@@@@@@@@@@@@ ",
+" @+..........+$@ ",
+" @...........+++@ ",
+" @...........+..+@ ",
+" @...........+...#@ ",
+" @...........+...++@ ",
+" @...........+@@@@@@@ ",
+" @............++++##@ ",
+" @.............++++#@ ",
+" @...............++#@ ",
+" @................+#@ ",
+" @.................#@ ",
+" @.................+@ ",
+" @.................+@ ",
+" @...............+++@ ",
+" @..............++++@ ",
+" @.............+++++@ ",
+" @............++++++@ ",
+" @............++++++@ ",
+" @+...+.+.+.++++++++@ ",
+" @+++++++++++++++++#@ ",
+" @@@@@@@@@@@@@@@@@@ ",
+" "};
diff --git a/lisp/toolbar/lc-open.xpm b/lisp/toolbar/lc-open.xpm
new file mode 100644
index 00000000000..0e074830bb6
--- /dev/null
+++ b/lisp/toolbar/lc-open.xpm
@@ -0,0 +1,35 @@
+/* XPM */
+static char * open2_xpm[] = {
+"24 24 8 1",
+" c None",
+". c #BBBDBA",
+"+ c #000100",
+"@ c #87AF85",
+"# c #FFFFFF",
+"$ c #6B6B66",
+"% c #504D46",
+"& c #3E4850",
+" ",
+" ",
+" ",
+" +++++++ ",
+" +.#####$% ",
+" +#.....@% ",
+"+.#......%+ ",
+"+..@@@...$%++++++++ ",
+"+.@@@@@..@@........+ ",
+"+.@@@@@@@@@@@@@@@@$+ ",
+"+.$$++++++++++++++++++ ",
+"+.$%################..& ",
+"+.$+#.................+ ",
+"+.%.#...............@$+ ",
+"+.+#...............@@%+ ",
+"+.$#............@@.@$+ ",
+"+....@@@@@.....@@@@$%+ ",
+"+.#..@@@@@@@@@@@@$$$+ ",
+"+#.@@@@$$$$$$$$$$$$%+ ",
+" +++++++++++++++++++ ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-paste.xpm b/lisp/toolbar/lc-paste.xpm
new file mode 100644
index 00000000000..c728f0f038c
--- /dev/null
+++ b/lisp/toolbar/lc-paste.xpm
@@ -0,0 +1,35 @@
+/* XPM */
+static char * paste2_xpm[] = {
+"24 24 8 1",
+" c None",
+". c #FFFFFF",
+"+ c #BBBDBA",
+"@ c #000100",
+"# c #6B6B66",
+"$ c #504D46",
+"% c #D3B354",
+"& c #974F3D",
+" @@@@ ",
+" @@@@@@+..#@@@@@@ ",
+"@.....$.++#$+...+@ ",
+"@.++++$.##+$#+++%@ ",
+"@.+++$..+++#$#++%@ ",
+"@.++$++++++#$$++%@ ",
+"@.++#$$$$$$$$#++%@ ",
+"@.+++########+++%@ ",
+"@.+++++#$@@@@@$$@@@@@ ",
+"@.+++++$+...........+@ ",
+"@.+++++$.............@ ",
+"@.+++++@.+##+..+#.#+.@ ",
+"@.+++++@.............@ ",
+"@.+++++$.##.###+.+#..@ ",
+"@.+++++$.............@ ",
+"@.+++++$.+##.###+.+#.@ ",
+"@.+++++@.............@ ",
+"@.+++++@.##.###+.+#..@ ",
+"@.+++++$.............@ ",
+"@.+++++$.+##.###+.+#.@ ",
+"@+%%%%&@.............@ ",
+" @@@@@@@+...........+@ ",
+" @@@@@@@@@@@@@ ",
+" "};
diff --git a/lisp/toolbar/lc-preferences.xpm b/lisp/toolbar/lc-preferences.xpm
new file mode 100644
index 00000000000..cebac821d6e
--- /dev/null
+++ b/lisp/toolbar/lc-preferences.xpm
@@ -0,0 +1,37 @@
+/* XPM */
+static char * preferences2_xpm[] = {
+"24 24 10 1",
+" c None",
+". c #000100",
+"+ c #BBBDBA",
+"@ c #FFFFFF",
+"# c #7A98B0",
+"$ c #6B6B66",
+"% c #4D687C",
+"& c #B0CCE2",
+"* c #504D46",
+"= c #3E4850",
+" .. ",
+" .++$. ",
+" .+++. .. ",
+" .@+. .@$. ",
+" .. =@+. .@++. ",
+" .+ ..+@+$. .++. ",
+" .+++@@+++. .@.. ",
+" .+++++++$. .@. ",
+" .....@@+$..+. ",
+" .@@+.+. ",
+" .@.+.. ",
+" .+.$*. ",
+" ....+.$$$$. ",
+" .#&#.. .+++$. ",
+" .#&+&%. .@@+$. ",
+" .#@#%&%. .@@+$. ",
+" .#@#%&#%. .@@+$..",
+" .&@#%&#%. .+$*+.",
+" .#@#%&#%. .+++.",
+" .&@#&#%.. ... ",
+" .#&&#%.. ",
+" .##%.. ",
+" ... ",
+" "};
diff --git a/lisp/toolbar/lc-print.xpm b/lisp/toolbar/lc-print.xpm
new file mode 100644
index 00000000000..8c67bb632f0
--- /dev/null
+++ b/lisp/toolbar/lc-print.xpm
@@ -0,0 +1,33 @@
+/* XPM */
+static char * print2_xpm[] = {
+"24 24 6 1",
+" c None",
+". c #FFFFFF",
+"+ c #000100",
+"@ c #BBBDBA",
+"# c #6B6B66",
+"$ c #504D46",
+" ",
+" ++++++++++++ ",
+" +@..........@+ ",
+" +.........@@@+ ",
+" +.###.#@@...@+ ",
+" +...........@+ ",
+" +.##@.#@.@#.@+ ",
+" +...........@+ ",
+" +.@@.@.@@@..@+ ",
+" +....@......@+ ",
+" ++.###@##@#@@@++ ",
+" +.+@@@@@@@@@@@@+#+ ",
+" +..#$++++++++++##@@+ ",
+" +....................+ ",
+" +@#...............@@@+ ",
+" +@#.@@@@@@@@@@@@@@#@#+ ",
+" +@#...............$##+ ",
+" +@#$$$$$$$$$$$$$$$$##+ ",
+" +@@###$#$$$$$$$$$$###+ ",
+" +#@@#########$#######+ ",
+" ++++++++++++++++++++ ",
+" +#@@@@@@@@@@@@@@@##+ ",
+" ++++++++++++++++++ ",
+" "};
diff --git a/lisp/toolbar/lc-right_arrow.xpm b/lisp/toolbar/lc-right_arrow.xpm
new file mode 100644
index 00000000000..a74b70c74b3
--- /dev/null
+++ b/lisp/toolbar/lc-right_arrow.xpm
@@ -0,0 +1,33 @@
+/* XPM */
+static char * right_arrow2_xpm[] = {
+"24 24 6 1",
+" c None",
+". c #87AF85",
+"+ c #000100",
+"@ c #BBBDBA",
+"# c #6B6B66",
+"$ c #504D46",
+" ",
+" ",
+" ",
+" + ",
+" ++ ",
+" +.+ ",
+" +..+ ",
+" ++++++++@..+ ",
+" +@@@@@@@@@..+ ",
+" +@@..........+ ",
+" +..........@..+ ",
+" +.............$+ ",
+" +............$+ ",
+" +...........$+ ",
+" +.######...$+ ",
+" ++++++++#.$+ ",
+" +#$+ ",
+" +$+ ",
+" ++ ",
+" + ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-save.xpm b/lisp/toolbar/lc-save.xpm
new file mode 100644
index 00000000000..fd3156abfbf
--- /dev/null
+++ b/lisp/toolbar/lc-save.xpm
@@ -0,0 +1,39 @@
+/* XPM */
+static char * save2_xpm[] = {
+"24 24 12 1",
+" c None",
+". c #FFFFFF",
+"+ c #000100",
+"@ c #BBBDBA",
+"# c #7A98B0",
+"$ c #6B6B66",
+"% c #EBA291",
+"& c #3E4850",
+"* c #B0CCE2",
+"= c #4D687C",
+"- c #504D46",
+"; c #974F3D",
+" ",
+" +++++++++++++++++++ ",
+" +**$%%%%%%%%%%%%@$**+ ",
+" +*#$%%%%%%%%;;%;;$#=+ ",
+" +*#$%%%%%%;%;%;;;$#=+ ",
+" +*#$.............$#=+ ",
+" +*#$.............$#=+ ",
+" +*#$@@@@@@@@@@@@@$#=+ ",
+" +*#$.............$#=+ ",
+" +*#$.............$#=+ ",
+" +*#$@@@@@@@@@@@@@$#$+ ",
+" +*#$.............$#&+ ",
+" +*##$$$$$$$$$$$$$$#&+ ",
+" +*#################&+ ",
+" +*###&&&==$$$$&&&#*&+ ",
+" +*##&@@....@@@@$==*&+ ",
+" +*##&@.$--@@@@@&==*&+ ",
+" +*##&..$--@@@@@&==*&+ ",
+" +*##&..---@@@..&==*&+ ",
+" +###&@@---@@...&==*&+ ",
+" +==&@@@@@@..@@&==*&+ ",
+" ++++++++++++++++&+ ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-saveas.xpm b/lisp/toolbar/lc-saveas.xpm
new file mode 100644
index 00000000000..11cc684c22d
--- /dev/null
+++ b/lisp/toolbar/lc-saveas.xpm
@@ -0,0 +1,40 @@
+/* XPM */
+static char * saveas2_xpm[] = {
+"24 24 13 1",
+" c None",
+". c #000100",
+"+ c #BBBDBA",
+"@ c #7A98B0",
+"# c #FFFFFF",
+"$ c #6B6B66",
+"% c #3E4850",
+"& c #B0CCE2",
+"* c #4D687C",
+"= c #EBA291",
+"- c #504D46",
+"; c #D3B354",
+"> c #974F3D",
+" .. ",
+" .;;. ",
+" .............;;-... ",
+" .&&$========.;;-.%@@. ",
+" .&@$=======.;;-.>-@*. ",
+" .&@$======.;;-.>>%@*. ",
+" .&@$#####.;;-.++#$@*. ",
+" .&@$####.;;-.++##$@*. ",
+" .&@$+++.;;-.+++++$@*. ",
+" .&@$###.;-.++####$@*. ",
+" .&@$##.-..++#####$@*. ",
+" .&@$++..+++++++++$@$. ",
+" .&@$###++########$@%. ",
+" .&@@$$$$$$$$$$$$$$@%. ",
+" .&@@@@@@@@@@@@@@@@@%. ",
+" .&@@@%%%**$$$$%%%@&%. ",
+" .&@@%++####++++$**&%. ",
+" .&@@%+#$--+++++%**&%. ",
+" .&@@%##$--+++++%**&%. ",
+" .&@@%##---+++##%**&%. ",
+" .@@@%++---++###%**&%. ",
+" .**%++++++##++%**&%. ",
+" ................%. ",
+" "};
diff --git a/lisp/toolbar/lc-search.xpm b/lisp/toolbar/lc-search.xpm
new file mode 100644
index 00000000000..478b63ff648
--- /dev/null
+++ b/lisp/toolbar/lc-search.xpm
@@ -0,0 +1,33 @@
+/* XPM */
+static char * search2_xpm[] = {
+"24 24 6 1",
+" c None",
+". c #FFFFFF",
+"+ c #BBBDBA",
+"@ c #000100",
+"# c #6B6B66",
+"$ c #504D46",
+" ",
+" @@@@@@@@@@@@@ ",
+" @+..........+$@ ",
+" @...........+++@ ",
+" @...........+..+@ ",
+" @...........+...#@ ",
+" @...........+...++@ ",
+" @....+$@@$+.+@@@@@@@ ",
+" @...+$+++#$+.++++##@ ",
+" @...$+..++#$..++++#@ ",
+" @...@+.++++@+...++#@ ",
+" @...@++++++@++...+#@ ",
+" @...$#+++++$++....#@ ",
+" @...+$#+++@@++....+@ ",
+" @...+#$@@$#@@+....+@ ",
+" @....++++++@@@+++++@ ",
+" @....++++++#@@@++++@ ",
+" @.....++++++#@@@+++@ ",
+" @..........++#@@+++@ ",
+" @..........++++++++@ ",
+" @+...+.+.+.++++++++@ ",
+" @+++++++++++++#####@ ",
+" @@@@@@@@@@@@@@@@@@ ",
+" "};
diff --git a/lisp/toolbar/lc-spell.xpm b/lisp/toolbar/lc-spell.xpm
new file mode 100644
index 00000000000..ec952467cc5
--- /dev/null
+++ b/lisp/toolbar/lc-spell.xpm
@@ -0,0 +1,35 @@
+/* XPM */
+static char * spell2_xpm[] = {
+"24 24 8 1",
+" c None",
+". c #000100",
+"+ c #87AF85",
+"@ c #504D46",
+"# c #BBBDBA",
+"$ c #6B6B66",
+"% c #3E4850",
+"& c #FFFFFF",
+" ",
+" ",
+" ",
+" ",
+" ... .... ... ",
+" .. . .. . .. . ",
+" .. . .... .. ",
+" ..... .. . .. ",
+" .. . .. . .. . . ",
+" .. . .... ... ... ",
+" .+. ",
+" .. .+@ ",
+" .+. .++. ",
+" @+. %#+. ",
+" .++. .#+$. ",
+" .++.&++. ",
+" .+++++$. ",
+" .++++. ",
+" .+++@. ",
+" .++. ",
+" .+@. ",
+" .. ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-undo.xpm b/lisp/toolbar/lc-undo.xpm
new file mode 100644
index 00000000000..8172fb2c951
--- /dev/null
+++ b/lisp/toolbar/lc-undo.xpm
@@ -0,0 +1,32 @@
+/* XPM */
+static char * undo2_xpm[] = {
+"24 24 5 1",
+" c None",
+". c #D3B354",
+"+ c #000100",
+"@ c #FFFFFF",
+"# c #6B6B66",
+" ",
+" ",
+" ",
+" + ",
+" ++ ",
+" +@+ ",
+" +@.++++ ",
+" +@......+ ",
+" +@........+ ",
+" +...........+ ",
+" +..........++ ",
+" +..........+ ",
+" +..+++....+ ",
+" +.+ ++...+ ",
+" ++ ++..+ ",
+" + +..+ ",
+" +..+ ",
+" +.+ ",
+" +.#+ ",
+" +..+ ",
+" ++ ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/lc-up_arrow.xpm b/lisp/toolbar/lc-up_arrow.xpm
new file mode 100644
index 00000000000..ed4b7526015
--- /dev/null
+++ b/lisp/toolbar/lc-up_arrow.xpm
@@ -0,0 +1,35 @@
+/* XPM */
+static char * up_arrow2_xpm[] = {
+"24 24 8 1",
+" c None",
+". c #87AF85",
+"+ c #000100",
+"@ c #504D46",
+"# c #6B6B66",
+"$ c #BBBDBA",
+"% c #FFFFFF",
+"& c #3E4850",
+" ",
+" ",
+" + ",
+" &$+ ",
+" +%.@+ ",
+" +%...@+ ",
+" +%.....@+ ",
+" +%......#@+ ",
+" +%.......##@+ ",
+" +%$$.....#@@@@+ ",
+" +++++$.....@+++++ ",
+" +$....#@+ ",
+" +$....#@+ ",
+" +$...##@+ ",
+" +$...##@+ ",
+" +$...##@+ ",
+" +...#@@@+ ",
+" +++++++++ ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/left_arrow.pbm b/lisp/toolbar/left_arrow.pbm
index 6d6f07f0983..56005e71c3f 100644
--- a/lisp/toolbar/left_arrow.pbm
+++ b/lisp/toolbar/left_arrow.pbm
Binary files differ
diff --git a/lisp/toolbar/left_arrow.xpm b/lisp/toolbar/left_arrow.xpm
index b3f0ae4ab9a..586fe4489c0 100644
--- a/lisp/toolbar/left_arrow.xpm
+++ b/lisp/toolbar/left_arrow.xpm
@@ -1,35 +1,69 @@
/* XPM */
static char * left_arrow_xpm[] = {
-"24 24 9 1",
+"24 24 43 1",
" c None",
-". c #020202",
-"+ c #121A12",
-"@ c #78A16E",
-"# c #86AD7D",
-"$ c #B2C6AE",
-"% c #263222",
-"& c #E7EDE6",
-"* c #497241",
+". c #000000",
+"+ c #B9D0B9",
+"@ c #CDDECB",
+"# c #B6C7B6",
+"$ c #B1C9B0",
+"% c #B3C4B3",
+"& c #B4CBB2",
+"* c #B5CEB5",
+"= c #B7CCB5",
+"- c #B9CEB7",
+"; c #BAD1BA",
+"> c #BBCFBA",
+", c #BBD0B9",
+"' c #B2C9B0",
+") c #7EAB78",
+"! c #AAC7A8",
+"~ c #B3CAB1",
+"{ c #B0C9B0",
+"] c #B0C9AE",
+"^ c #AEC7AC",
+"/ c #AAC5A8",
+"( c #A9C4A7",
+"_ c #698267",
+": c #2D2D2D",
+"< c #CFDFCC",
+"[ c #ADC8AB",
+"} c #B0C7AE",
+"| c #ADC6AB",
+"1 c #678C63",
+"2 c #9BAD9A",
+"3 c #85AE81",
+"4 c #87AF84",
+"5 c #87B083",
+"6 c #88AF84",
+"7 c #88B085",
+"8 c #86AF82",
+"9 c #547150",
+"0 c #3C5235",
+"a c #5B7950",
+"b c #4A6342",
+"c c #3B5035",
+"d c #415639",
" ",
" ",
" ",
-" ",
-" ",
-" .. ",
-" ..$. ",
-" ..&&$. ",
-" ..&&&&$. ",
-" ..&&&&&&$. ",
-" .+&&&&&&&&$. ",
-" ..$&&&&&&&&&$% ",
-" ..**@@@#####@. ",
-" ..**@#@###@. ",
-" ..**@#@#@. ",
-" ..**@@@. ",
-" ..*@*. ",
-" ..*. ",
-" .. ",
-" ",
+" . ",
+" .. ",
+" .+. ",
+" .@#. ",
+" .@$%........ ",
+" .@&*=-;->,'). ",
+" .@!~{]^///^(_. ",
+" :<[}||[!^^}^[1. ",
+" .23444445645789. ",
+" .0aaaaaaaaaaab. ",
+" .0aaaaaaaaaab. ",
+" .0aabccccccd. ",
+" .0ab........ ",
+" .0b. ",
+" .b. ",
+" .. ",
+" . ",
" ",
" ",
" ",
diff --git a/lisp/toolbar/new.pbm b/lisp/toolbar/new.pbm
index 93415bf901e..1fae8c09eec 100644
--- a/lisp/toolbar/new.pbm
+++ b/lisp/toolbar/new.pbm
Binary files differ
diff --git a/lisp/toolbar/new.xpm b/lisp/toolbar/new.xpm
index bd45e8962a8..2d4690edd3c 100644
--- a/lisp/toolbar/new.xpm
+++ b/lisp/toolbar/new.xpm
@@ -1,37 +1,154 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 7 1",
-" c Gray0",
-". c #61b761b7600a",
-"X c #828282827474",
-"o c #a5d8a5d89550",
-"O c #d305d305bc3c",
-"+ c #ea03ea03d271",
-"@ c None",
-/* pixels */
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@",
-"@@@@@@@@@@@@@ @@@@@@@@@@",
-"@@@@@@@@@@@ o @@@@@@@@@",
-"@@@@@@@@@ oO+ @@@@@@@@@",
-"@@@@@@@ oOOOO+ @@@@@@@@",
-"@@@@@ oOOOOOO+o @@@@@@@",
-"@@@@ ..OOOOOO+++.@@@@@@@",
-"@@@@ +.OOOOO+++++ @@@@@@",
-"@@@@ ++.OOO++++++o @@@@@",
-"@@@@ ++.oOO+++++++ @@@@@",
-"@@@@ +.oOO+++++++++ @@@@",
-"@@@@ oOO++++++++++O @@@",
-"@@@@ .OOO+++++++++++O @@",
-"@@@@ oOO++++++++++++X @@",
-"@@@@@ +++++++++++++ @@@",
-"@@@@@ O++++++++++O @@@@@",
-"@@@@@@.+++++++++X @@@@@@",
-"@@@@@@ +++++++O @@@@@@@@",
-"@@@@@@@ +++++o @@@@@@@@@",
-"@@@@@@@ O++O. @@@@@@@@@@",
-"@@@@@@@@ +o @@@@@@@@@@@@",
-"@@@@@@@@@ @@@@@@@@@@@@@",
-"@@@@@@@@@@@@@@@@@@@@@@@@"
-};
+static char * new_xpm[] = {
+"24 24 127 2",
+" c None",
+". c #000000",
+"+ c #D3D3D3",
+"@ c #F6F6F6",
+"# c #FFFFFF",
+"$ c #F9F9F9",
+"% c #DADADA",
+"& c #585858",
+"* c #C7C7C7",
+"= c #D1D1D1",
+"- c #D6D6D6",
+"; c #FEFEFE",
+"> c #FDFDFD",
+", c #C0C0C0",
+"' c #E1E1E1",
+") c #F0F0F0",
+"! c #9B9B9B",
+"~ c #FCFCFB",
+"{ c #FBFBFB",
+"] c #AFAFAE",
+"^ c #E9E9E9",
+"/ c #DFDFDF",
+"( c #8F8F8F",
+"_ c #FAFAF9",
+": c #F9F9F8",
+"< c #A4A4A3",
+"[ c #F4F4F4",
+"} c #CFCFCF",
+"| c #A2A2A2",
+"1 c #F8F8F7",
+"2 c #F8F7F6",
+"3 c #9E9E9E",
+"4 c #F7F6F5",
+"5 c #F6F6F4",
+"6 c #F4F3F2",
+"7 c #DEDDDC",
+"8 c #D3D2D0",
+"9 c #B7B7B5",
+"0 c #9F9E9D",
+"a c #706F6F",
+"b c #65625A",
+"c c #F5F4F3",
+"d c #F2F2F0",
+"e c #E4E4E2",
+"f c #DAD9D7",
+"g c #D8D8D6",
+"h c #CDCCCA",
+"i c #AFAEAC",
+"j c #88847B",
+"k c #F3F3F1",
+"l c #EFEFED",
+"m c #EEEDEB",
+"n c #EDECEA",
+"o c #E9E8E6",
+"p c #D5D4D3",
+"q c #C4C3C2",
+"r c #8F8A81",
+"s c #F6F5F4",
+"t c #F5F5F3",
+"u c #F1F1EF",
+"v c #F1F0EE",
+"w c #ECEBE9",
+"x c #EAE9E7",
+"y c #E5E4E2",
+"z c #E4E3E0",
+"A c #D2D1CE",
+"B c #8D887E",
+"C c #F3F2F1",
+"D c #F0F0EE",
+"E c #F0EFED",
+"F c #EFEEEC",
+"G c #E8E7E5",
+"H c #E5E4E1",
+"I c #E2E1DE",
+"J c #E1DFDC",
+"K c #979288",
+"L c #A49E93",
+"M c #E8E7E4",
+"N c #E7E6E3",
+"O c #E3E2DF",
+"P c #E2E0DD",
+"Q c #E1E0DC",
+"R c #E0DFDB",
+"S c #A19C90",
+"T c #EDEDEB",
+"U c #EBEAE8",
+"V c #E9E8E5",
+"W c #E6E4E1",
+"X c #E3E2DE",
+"Y c #DFDEDA",
+"Z c #DEDDD9",
+"` c #DDDCD8",
+" . c #A19B90",
+".. c #E7E5E2",
+"+. c #E4E3DF",
+"@. c #DCDBD7",
+"#. c #E6E5E2",
+"$. c #E5E4E0",
+"%. c #E2E1DD",
+"&. c #DBD9D5",
+"*. c #D9D7D3",
+"=. c #9F998D",
+"-. c #E4E2DF",
+";. c #DDDBD7",
+">. c #DCDAD6",
+",. c #D8D6D2",
+"'. c #9E988D",
+"). c #EDEDED",
+"!. c #E1E0DD",
+"~. c #E0DEDA",
+"{. c #D8D6D1",
+"]. c #D7D5D1",
+"^. c #9D978B",
+"/. c #E1DFDB",
+"(. c #DEDCD8",
+"_. c #D7D6D1",
+":. c #D5D3CE",
+"<. c #9B958A",
+"[. c #999891",
+"}. c #A39E92",
+"|. c #A39D92",
+"1. c #A39D91",
+"2. c #A29C90",
+"3. c #A19B8F",
+"4. c #9D978C",
+"5. c #9B968A",
+"6. c #676359",
+" ",
+" . . . . . . . . . . . . . ",
+" . + @ # # # # # # # # $ % & . ",
+" . @ # # # # # # # # # # * = - . ",
+" . # # # # # # # ; # ; > , ' ) ! . ",
+" . # # # # # ; > ~ > ~ { ] ^ # / ( . ",
+" . # # # ; > ~ { _ { _ : < ) # [ } | . ",
+" . # ; > ~ { _ : 1 : 1 2 3 . . . . . . . ",
+" . # ~ { _ : 1 2 4 2 4 5 6 7 8 9 0 a b . ",
+" . # _ : 1 2 4 5 c 5 c 6 d e f g h i j . ",
+" . # 1 2 4 5 c 6 k 6 k d l m n o p q r . ",
+" . # s t 6 6 k d u d u v m w x y z A B . ",
+" . # 6 C d D l v E v E F w G H z I J K . ",
+" . # 6 C d D l v E v E F w G H z I J L . ",
+" . # D l l F m n n n n w M N O P Q R S . ",
+" . # T n w w w U V U V V H W X Y Z ` .. ",
+" . # U o o G M M N M N ..+.X R Z ` @. .. ",
+" . # N #.#.#.H W $.W $.+.%.R Z @.&.*.=.. ",
+" . $ z O X -.+.%.X %.X Q Q Z ;.>.*.,.'.. ",
+" . ).!.J Q R %.R Q R Q Y ~.;.>.*.{.].^.. ",
+" . = /.~.Y Z R Z ~.Z ~.(.(.>.>.,._.:.<.. ",
+" . [.}.L |.1.|.S 2.S 2.3. .=.=.4.4.5.6.. ",
+" . . . . . . . . . . . . . . . . . . ",
+" "};
diff --git a/lisp/toolbar/open.pbm b/lisp/toolbar/open.pbm
index 3d2be258a67..9c614e43f31 100644
--- a/lisp/toolbar/open.pbm
+++ b/lisp/toolbar/open.pbm
Binary files differ
diff --git a/lisp/toolbar/open.xpm b/lisp/toolbar/open.xpm
index 62b70e7468b..6b95c7e476d 100644
--- a/lisp/toolbar/open.xpm
+++ b/lisp/toolbar/open.xpm
@@ -1,34 +1,200 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 4 1",
-" c Gray0",
-". c #999990907b7b",
-"X c #fffffefef7f7",
-"o c None",
-/* pixels */
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooo oooooooo",
-"ooooooooooo .. ooooooo",
-"oooo oo ....XXo ooo",
-"ooo .. ....XXXX .. ooo",
-"ooo .....XXXXX .... ooo",
-"oooo ..XXXXX ...... ooo",
-"oooo ..XXX ........ ooo",
-"ooooo .XX .......... ooo",
-"ooooo ..X .......... ooo",
-"oooooo .X .......... ooo",
-"oooooo .. ........ oooo",
-"ooooooo . ...... oooooo",
-"ooooooo . ..... oooooooo",
-"oooooooo ... ooooooooo",
-"oooooooo . ooooooooooo",
-"ooooooooo ooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo",
-"oooooooooooooooooooooooo"
-};
+static char * open_xpm[] = {
+"24 24 173 2",
+" c None",
+". c #000000",
+"+ c #010100",
+"@ c #B5B8A5",
+"# c #E4E7D2",
+"$ c #878A76",
+"% c #33342B",
+"& c #0B0B0B",
+"* c #E2E5CF",
+"= c #CFD4AF",
+"- c #CED3AE",
+"; c #B2B696",
+"> c #2D2D25",
+", c #23241D",
+"' c #9D9F90",
+") c #C6CAA6",
+"! c #C4C9A5",
+"~ c #C6CBA7",
+"{ c #C7CCA8",
+"] c #C9CEA9",
+"^ c #555847",
+"/ c #1A1B15",
+"( c #20201A",
+"_ c #D4D6C2",
+": c #BEC2A0",
+"< c #B3B896",
+"[ c #B0B595",
+"} c #B3B797",
+"| c #B6BB99",
+"1 c #BBC09E",
+"2 c #BCC19F",
+"3 c #81856C",
+"4 c #3E3F32",
+"5 c #010101",
+"6 c #DADDC8",
+"7 c #AFB494",
+"8 c #AAAF8F",
+"9 c #A3A789",
+"0 c #A6AA8B",
+"a c #A9AD8E",
+"b c #A7AB8D",
+"c c #A4A88A",
+"d c #A1A588",
+"e c #AAAD96",
+"f c #B3B5A5",
+"g c #B8BBAA",
+"h c #BABCAB",
+"i c #C1C3B2",
+"j c #C7CAB7",
+"k c #CACDBB",
+"l c #BABDA8",
+"m c #0C0C09",
+"n c #DDDFCB",
+"o c #969B7E",
+"p c #9DA286",
+"q c #95987C",
+"r c #96997E",
+"s c #9A9D81",
+"t c #999D80",
+"u c #9DA184",
+"v c #A5AA8B",
+"w c #A4A98A",
+"x c #A3A889",
+"y c #A2A588",
+"z c #A2A587",
+"A c #9FA386",
+"B c #9B9E83",
+"C c #898D74",
+"D c #D8DBC9",
+"E c #84866E",
+"F c #7D8169",
+"G c #151612",
+"H c #D7DAC9",
+"I c #797D67",
+"J c #3D3F34",
+"K c #E0E0D9",
+"L c #EBEDDD",
+"M c #E8EBD9",
+"N c #E7EAD8",
+"O c #E3E6D4",
+"P c #DEE1D0",
+"Q c #DADCCC",
+"R c #DADCD1",
+"S c #2B2C28",
+"T c #D7DAC6",
+"U c #6F735E",
+"V c #0D0D0D",
+"W c #F4F4EC",
+"X c #CACFAB",
+"Y c #C6CBA8",
+"Z c #C2C6A4",
+"` c #ABB091",
+" . c #23251E",
+".. c #494B3D",
+"+. c #DCDCD4",
+"@. c #EAECDD",
+"#. c #CDD2AD",
+"$. c #CCD1AC",
+"%. c #CACFAA",
+"&. c #BABF9D",
+"*. c #B5B999",
+"=. c #81836C",
+"-. c #070806",
+";. c #D5D8C4",
+">. c #161616",
+",. c #F2F2EA",
+"'. c #C9CEAA",
+"). c #C8CDA9",
+"!. c #C4C9A6",
+"~. c #C1C5A3",
+"{. c #BCC09F",
+"]. c #B6BB9A",
+"^. c #B0B494",
+"/. c #9DA185",
+"(. c #535445",
+"_. c #B6B8A7",
+":. c #747470",
+"<. c #ECECE2",
+"[. c #C3C8A5",
+"}. c #C2C7A4",
+"|. c #C0C5A2",
+"1. c #BFC4A1",
+"2. c #BDC2A0",
+"3. c #B9BD9C",
+"4. c #B9BE9D",
+"5. c #A9AD8F",
+"6. c #A3A78A",
+"7. c #80836D",
+"8. c #020201",
+"9. c #A6A998",
+"0. c #B8BC9B",
+"a. c #AFB394",
+"b. c #ACB091",
+"c. c #A8AC8E",
+"d. c #A6AA8C",
+"e. c #9FA286",
+"f. c #9B9F83",
+"g. c #9A9D82",
+"h. c #8A8D75",
+"i. c #4F5243",
+"j. c #070705",
+"k. c #9E9F91",
+"l. c #E5E6DA",
+"m. c #ADB192",
+"n. c #A5A98C",
+"o. c #9FA387",
+"p. c #999D81",
+"q. c #95987E",
+"r. c #92957B",
+"s. c #8C8F76",
+"t. c #8A8D74",
+"u. c #71735F",
+"v. c #080908",
+"w. c #E3E5D9",
+"x. c #C0C3AF",
+"y. c #94987C",
+"z. c #8F9379",
+"A. c #8B8F75",
+"B. c #8A8E74",
+"C. c #888C73",
+"D. c #858970",
+"E. c #868971",
+"F. c #82866E",
+"G. c #80836C",
+"H. c #7D8069",
+"I. c #797C66",
+"J. c #727560",
+"K. c #717460",
+"L. c #71745F",
+"M. c #6A6D59",
+"N. c #434538",
+"O. c #080907",
+"P. c #050504",
+" ",
+" ",
+" ",
+" . . . . . . . ",
+" + @ # # # # # $ % ",
+" & * = = = - - ; > ",
+", ' * ) ! ~ { ] ] ^ / ",
+"( _ : < [ } | 1 2 3 4 5 . . . . . . . ",
+", 6 7 8 9 0 8 a b c d e f g h i j k l . ",
+"m n o p q r s t r u v w x y 9 z A B C . ",
+". D E F G . . . . . . . . . . . . . . . 5 5 ",
+". H I J K L M M M M M M M M M M M N O P Q R S ",
+". T U V W = = = = = = = = = - - - X Y Z 1 ` . ",
+". T ..+.@.#.- - #.- #.#.#.#.#.$.%.Y Z &.*.=.-. ",
+". ;.>.,.X %.X %.'.%.'.{ ).).Y !.~.{.].^./.(.m ",
+". _.:.<.[.}.}.Z |.Z 1.2.|.2.3.4.} [ 5.6.7.8. ",
+". 9.+.0.0.*.} } [ [ a.a.a.b.c.d.e.f.g.h.i.j. ",
+". k.l.m.5.d.n.6.6.d o.e.f.p.q.r.s.t.t.u.v. ",
+". w.x.y.z.A.B.C.C.D.E.F.G.H.I.J.K.L.M.N.O. ",
+" . . . . . . . . . . . . . . . . . . P. ",
+" ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/paste.pbm b/lisp/toolbar/paste.pbm
index e51819c682a..17e3a82c0c6 100644
--- a/lisp/toolbar/paste.pbm
+++ b/lisp/toolbar/paste.pbm
Binary files differ
diff --git a/lisp/toolbar/paste.xpm b/lisp/toolbar/paste.xpm
index bc4fc3b965e..cdd86366d66 100644
--- a/lisp/toolbar/paste.xpm
+++ b/lisp/toolbar/paste.xpm
@@ -1,35 +1,116 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 5 1",
-" c Gray0",
-". c #62ee62ee62ee",
-"X c Gray68",
-"o c Gray82",
-"O c None",
-/* pixels */
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOO OOOOOOOOOOOO",
-"OOOOOOO ooo OOOOOO OOOO",
-"OOOOO ooooo OOO OOO",
-"OOO oo. .Xoo OO OOO",
-"OO ooo.oX..oo OOOOO OOOO",
-"OO ooo.X..oooo OOOOOOOOO",
-"OOO oo..Xooooo O OOOOOO",
-"OOO oooooooooo oX OOOOO",
-"OOOO ooooooo XXoo OOOOO",
-"OOOO ooooooo o.XooX OOOO",
-"OOOOO oooooo o.Xooo OOOO",
-"OOOOO oooooo .XooooX OOO",
-"OOOOOO ooooX XooooooX OO",
-"OOOOOO XXOXX Xooooooo OO",
-"OOOOOOO XXXX oooooooX O",
-"OOOOOOO XX O XooooX OO",
-"OOOOOOOO OOOO ooX OOOO",
-"OOOOOOOOOOOOOO X OOOOOO",
-"OOOOOOOOOOOOOOO OOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO"
-};
+static char * paste_xpm[] = {
+"24 24 89 1",
+" c None",
+". c #000000",
+"+ c #B9B9B9",
+"@ c #FEFEFE",
+"# c #F9F9F9",
+"$ c #757575",
+"% c #F5F5E8",
+"& c #565651",
+"* c #FFFFFF",
+"= c #A0A0A0",
+"- c #939393",
+"; c #7C7C7C",
+"> c #C5C5BB",
+", c #CFC6A0",
+"' c #D7CEAA",
+") c #ADA689",
+"! c #4B483C",
+"~ c #6D6D6D",
+"{ c #6C6C6C",
+"] c #A9A9A9",
+"^ c #3D3A30",
+"/ c #979178",
+"( c #C1B898",
+"_ c #8A793D",
+": c #C3BB9A",
+"< c #AFA78A",
+"[ c #444236",
+"} c #FAFAFA",
+"| c #EFEFEF",
+"1 c #C7C7C7",
+"2 c #D8D8D8",
+"3 c #D2D2D2",
+"4 c #7B7B7B",
+"5 c #302E26",
+"6 c #89846C",
+"7 c #C4BC9A",
+"8 c #847235",
+"9 c #C5C5C5",
+"0 c #A7A7A7",
+"a c #ADADAD",
+"b c #9A9A9A",
+"c c #9B9B9B",
+"d c #868686",
+"e c #424242",
+"f c #847033",
+"g c #C9C09E",
+"h c #464337",
+"i c #35332A",
+"j c #2D2B23",
+"k c #C6BE9D",
+"l c #826F33",
+"m c #7F7964",
+"n c #4C493C",
+"o c #171612",
+"p c #13120F",
+"q c #3E3B31",
+"r c #282210",
+"s c #474438",
+"t c #B3B3B3",
+"u c #D6D6D6",
+"v c #B7AE90",
+"w c #B1AA8C",
+"x c #37352B",
+"y c #151410",
+"z c #8F8F8F",
+"A c #989898",
+"B c #C6C6C6",
+"C c #B9B293",
+"D c #11100D",
+"E c #434035",
+"F c #636363",
+"G c #767676",
+"H c #AAA48B",
+"I c #A5A086",
+"J c #A19A7F",
+"K c #312F26",
+"L c #AFA88C",
+"M c #050403",
+"N c #12110E",
+"O c #A9A489",
+"P c #A39E85",
+"Q c #EBE7D0",
+"R c #D2C9A5",
+"S c #A29053",
+"T c #8E7C3D",
+"U c #88793B",
+"V c #806C2F",
+"W c #78652B",
+"X c #251F0C",
+" .... ",
+" ......+@#$...... ",
+".%%%%%&*=-;&>%%%,. ",
+".%''')!*~{]^/(''_. ",
+".%::<[}|123456<78. ",
+".%''!900abcde!)'f. ",
+".%g:6hijjjjj56<kl. ",
+".%'''////////(''l. ",
+".%g::::mnopppp^qr.... ",
+".%'''''st***********u. ",
+".%vwwwwx*************. ",
+".%'''''y*0zzA**Bz*zB*. ",
+".%CwwwwD*************. ",
+".%'''''E*~F*GzzB*Bz**. ",
+".%HIJJJK*************. ",
+".%'''''E*0zz*zzzB*Az*. ",
+".%LIJJJM*************. ",
+".%'''''N*~F*GzzB*Bz**. ",
+".%OPJJJK*************. ",
+".Q'''''E*0zz*zzzB*Az*. ",
+".RSTUVWX*************. ",
+" .......u***********u. ",
+" ............. ",
+" "};
diff --git a/lisp/toolbar/preferences.pbm b/lisp/toolbar/preferences.pbm
index 08819766ec0..00c7da36cdf 100644
--- a/lisp/toolbar/preferences.pbm
+++ b/lisp/toolbar/preferences.pbm
Binary files differ
diff --git a/lisp/toolbar/preferences.xpm b/lisp/toolbar/preferences.xpm
index e9a7656bcdc..3cdc884dd4d 100644
--- a/lisp/toolbar/preferences.xpm
+++ b/lisp/toolbar/preferences.xpm
@@ -1,35 +1,114 @@
/* XPM */
static char * preferences_xpm[] = {
-"24 24 8 1",
+"24 24 87 1",
" c None",
". c #000000",
-"+ c #E1E0E0",
-"@ c #D7C99B",
-"# c #9A6C4E",
-"$ c #A4A199",
-"% c #858579",
-"& c #AD8E30",
-" ",
-" ",
-" ",
-" .. ",
-" ..++. . ",
-" ..++++. .@. ",
-" ...+++++++. .@#. ",
-" ..++++++++++. .@#. ",
-" .++++++#++++++.@#. ",
-" .+++++#++++++.@#. ",
-" .++#+#+++++.@#. ",
-" .++#$#++++.@#.+. ",
-" .++##+++.@#.++@. ",
-" .++++++.@#.+++@%. ",
-" .++++&+..@$$$$%. ",
-" .++++..$$$$$$@. ",
-" .+$%%$+++++.. ",
-" .+++++++++. ",
-" .++++++.. ",
-" .++++@. ",
-" .++.. ",
-" .. ",
-" ",
+"+ c #BAB5AB",
+"@ c #D0CDC6",
+"# c #88857D",
+"$ c #C9C6BE",
+"% c #CCC8C1",
+"& c #E5E3E0",
+"* c #FFFFFF",
+"= c #757575",
+"- c #2E2E2E",
+"; c #F6F5F5",
+"> c #CCCCCC",
+", c #AFAFAF",
+"' c #D3D1CB",
+") c #C1C0BF",
+"! c #F0EFED",
+"~ c #797772",
+"{ c #DCDCDC",
+"] c #A5A19C",
+"^ c #EAE9E5",
+"/ c #F3F1F0",
+"( c #EDEDED",
+"_ c #A19D96",
+": c #C1BDB4",
+"< c #DBD8D3",
+"[ c #D9D6D1",
+"} c #89857E",
+"| c #FCFCFC",
+"1 c #EAE9E6",
+"2 c #F5F4F3",
+"3 c #C6C2BA",
+"4 c #F0EFEE",
+"5 c #F4F4F3",
+"6 c #CBC7C0",
+"7 c #ECECEB",
+"8 c #676560",
+"9 c #54524D",
+"0 c #777676",
+"a c #797978",
+"b c #85827E",
+"c c #79756F",
+"d c #7590AE",
+"e c #A4BAD0",
+"f c #90A6BE",
+"g c #9F9F9E",
+"h c #BEBDBC",
+"i c #B8B4AD",
+"j c #87837C",
+"k c #D3DFEA",
+"l c #A2AEBC",
+"m c #9DB6CE",
+"n c #637B95",
+"o c #E2E2E2",
+"p c #EEEEED",
+"q c #849CB6",
+"r c #D7E2ED",
+"s c #8D98A5",
+"t c #9DB8D2",
+"u c #607791",
+"v c #EDEDEC",
+"w c #99ADC3",
+"x c #DFE7F0",
+"y c #8193A9",
+"z c #586D84",
+"A c #5B7189",
+"B c #F1F1F1",
+"C c #EEEDEB",
+"D c #A7A6A5",
+"E c #726F6A",
+"F c #A1B4C8",
+"G c #EEF3F6",
+"H c #60768F",
+"I c #DEDDDC",
+"J c #787776",
+"K c #4E4E4D",
+"L c #91A6BE",
+"M c #F0F4F7",
+"N c #97A5B6",
+"O c #BFBEBD",
+"P c #AAAAA9",
+"Q c #ACACAB",
+"R c #B0C6DB",
+"S c #EDF2F6",
+"T c #818A95",
+"U c #6C85A1",
+"V c #C0D1E2",
+" .. ",
+" .+@#. ",
+" .$%+. .. ",
+" .&$. .*=. ",
+" .. -;$. .*>,. ",
+" .' ..)!+~. .{,. ",
+" .]%%^/+++. .(.. ",
+" ._:%$<[+}. .|. ",
+" .....123}..>. ",
+" .456.,. ",
+" .7.,.. ",
+" .,.89. ",
+" ....,.0abc. ",
+" .def.. .ghij. ",
+" .dklmn. .op6}. ",
+" .qrsntu. .v/$}. ",
+" .wxyztdA. .BCDE..",
+" .FGyHtdA. .IJK,.",
+" .LMNHtdA. .OPQ.",
+" .RSTtdA.. ... ",
+" .UtVLA.. ",
+" .UUn.. ",
+" ... ",
" "};
diff --git a/lisp/toolbar/print.pbm b/lisp/toolbar/print.pbm
index 63cea6d84d2..a4ab55c2cd8 100644
--- a/lisp/toolbar/print.pbm
+++ b/lisp/toolbar/print.pbm
Binary files differ
diff --git a/lisp/toolbar/print.xpm b/lisp/toolbar/print.xpm
index 06dee7c26bf..95f2f400800 100644
--- a/lisp/toolbar/print.xpm
+++ b/lisp/toolbar/print.xpm
@@ -1,36 +1,202 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 6 1",
-" c #043904390439",
-". c #40403f3f3f3f",
-"X c #5a1a5a0458f3",
-"o c #a74da686a5ec",
-"O c #e88de7c9e66c",
-"+ c None",
-/* pixels */
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++ ++++++++++",
-"+++++++++++ OOX +++++++",
-"++++++++++ OOOOOO. +++",
-"+++++++++ OOOOOOOOOo +++",
-"+++++++++.OOOOOOOOO ++++",
-"+++++++ oOOOOOOOOX+++++",
-"+++++ OooXOOOOOOo ++++",
-"+++ OOOOOoXXooOO.XX ++",
-"++ ooOOOOOOOOoXXX.X.. ++",
-"++ ooooOOOOOOOOOO.... ++",
-"++ ooooooOOOOOOO..... ++",
-"++ XooooooooOOO...... ++",
-"++ X.XoooooooX....... ++",
-"++ XX...XooooX...... ++",
-"+++ XXXX...XX..... ++++",
-"+++++ .XXXXX... +++++",
-"++++++++ .XX.. +++++++",
-"+++++++++++ ++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++",
-"++++++++++++++++++++++++"
-};
+static char * print_xpm[] = {
+"24 24 175 2",
+" c None",
+". c #000000",
+"+ c #C7C7C7",
+"@ c #FAFAFA",
+"# c #FCFCFC",
+"$ c #FBFBFB",
+"% c #F8F8F8",
+"& c #AFAFAF",
+"* c #F9F9F9",
+"= c #E5E5E5",
+"- c #E3E3E3",
+"; c #E2E2E2",
+"> c #E0E0E0",
+", c #DFDFDF",
+"' c #DCDCDC",
+") c #DBDBDB",
+"! c #B6B6B6",
+"~ c #6B6B6B",
+"{ c #676767",
+"] c #818181",
+"^ c #E7E7E7",
+"/ c #606060",
+"( c #A0A0A0",
+"_ c #DADADA",
+": c #E1E1E1",
+"< c #B7B7B7",
+"[ c #FDFDFD",
+"} c #EFEFEF",
+"| c #EEEEEE",
+"1 c #EDEDED",
+"2 c #ECECEC",
+"3 c #EBEBEB",
+"4 c #E9E9E9",
+"5 c #E8E8E8",
+"6 c #BFBFBF",
+"7 c #8A8A8A",
+"8 c #6A6A6A",
+"9 c #9E9E9E",
+"0 c #F6F6F6",
+"a c #909090",
+"b c #A2A2A2",
+"c c #AAAAAA",
+"d c #F4F4F4",
+"e c #CECECE",
+"f c #ADADAD",
+"g c #AEAEAE",
+"h c #BEBEBE",
+"i c #A6A6A6",
+"j c #CDCDCD",
+"k c #F5F5F5",
+"l c #DEDEDE",
+"m c #DDDDDD",
+"n c #C9C9C9",
+"o c #878787",
+"p c #888888",
+"q c #D0D0D0",
+"r c #6E6E6E",
+"s c #797979",
+"t c #D1D1D1",
+"u c #A1A1A1",
+"v c #B3B3B3",
+"w c #FFFFFF",
+"x c #CACACA",
+"y c #A7A7A7",
+"z c #A5A5A5",
+"A c #A4A4A4",
+"B c #A3A3A3",
+"C c #87847C",
+"D c #EAE8E3",
+"E c #8D8982",
+"F c #53524C",
+"G c #807D74",
+"H c #AAA9A5",
+"I c #BAB5AB",
+"J c #F3F3F3",
+"K c #C3C1BD",
+"L c #8B8B89",
+"M c #E6E5E1",
+"N c #F9F9F8",
+"O c #FAFAF9",
+"P c #F9F9F7",
+"Q c #F7F6F5",
+"R c #F7F7F4",
+"S c #F6F5F4",
+"T c #F2F1EE",
+"U c #F0EFEC",
+"V c #E5E5E4",
+"W c #9F9F9F",
+"X c #DFDED9",
+"Y c #A4A3A1",
+"Z c #6C6B6A",
+"` c #F5F4F3",
+" . c #D5D5D5",
+".. c #D3D3D3",
+"+. c #D4D4D3",
+"@. c #D4D4D4",
+"#. c #A9A9A9",
+"$. c #B5B5B5",
+"%. c #CDCDCB",
+"&. c #B5B5B4",
+"*. c #DCDAD3",
+"=. c #6B6B6A",
+"-. c #999896",
+";. c #918F87",
+">. c #999895",
+",. c #E6E4E1",
+"'. c #F0EEEC",
+"). c #FAF9F9",
+"!. c #F9F8F7",
+"~. c #F8F7F6",
+"{. c #F8F8F7",
+"]. c #F4F3F1",
+"^. c #F2F1EF",
+"/. c #565655",
+"(. c #858482",
+"_. c #9C9B99",
+":. c #6B6A68",
+"<. c #585858",
+"[. c #5E5C57",
+"}. c #524F4B",
+"|. c #4A4845",
+"1. c #4B4A46",
+"2. c #4B4946",
+"3. c #4A4844",
+"4. c #494743",
+"5. c #484642",
+"6. c #474541",
+"7. c #464440",
+"8. c #514F4B",
+"9. c #53514E",
+"0. c #7B7A77",
+"a. c #797771",
+"b. c #949391",
+"c. c #989694",
+"d. c #868480",
+"e. c #6E6C66",
+"f. c #706D67",
+"g. c #5C5955",
+"h. c #67645F",
+"i. c #5B5954",
+"j. c #585651",
+"k. c #5D5B56",
+"l. c #595652",
+"m. c #53504C",
+"n. c #575450",
+"o. c #595752",
+"p. c #5C5956",
+"q. c #5B5956",
+"r. c #61615E",
+"s. c #696861",
+"t. c #77756F",
+"u. c #7E7B77",
+"v. c #979690",
+"w. c #96938D",
+"x. c #807E77",
+"y. c #7D7A74",
+"z. c #787770",
+"A. c #716F6A",
+"B. c #6E6C67",
+"C. c #595753",
+"D. c #63615C",
+"E. c #686661",
+"F. c #6F6E68",
+"G. c #6D6C66",
+"H. c #72716B",
+"I. c #76746F",
+"J. c #6A6963",
+"K. c #8B8880",
+"L. c #B2AFA8",
+"M. c #B6B3AD",
+"N. c #BFBDB6",
+"O. c #BDBBB4",
+"P. c #B0AEA6",
+"Q. c #ABA8A2",
+"R. c #9C9991",
+" ",
+" . . . . . . . . . . . . ",
+" . + @ # # # # # # # $ % & . ",
+" . * = - - - ; > , , ' ) ! . ",
+" . # ~ { ] ^ / ( _ : > > < . ",
+" . [ } | 1 1 | 2 2 3 4 5 6 . ",
+" . [ 7 8 9 0 a b 4 c a d + . ",
+" . [ # # # # $ $ # # $ $ e . ",
+" . [ f g = h % h i j 3 # j . ",
+" . k l l l m l l , l 5 : n . ",
+" . . @ o ~ p q r s t p u q v . . ",
+" . w . x y z A z z i B b u u 9 . C . ",
+" . w D E F . . . . . . . . . . G C H I . ",
+" . w w J w w w w w w w w w w w w w w w w D . ",
+" . K L M N O N P Q R O O S T T U V D W X I . ",
+" . Y Z ` h .! ..! +.< @.#...$.%.&.*.=.-.;.. ",
+" . >.=.,.'.Q N @ ).N !.~.{.{.].].].^./.(.;.. ",
+" . _.:.<.[.}.|.1.2.2.2.3.4.5.6.4.7.8.9.0.a.. ",
+" . b.c.d.e.f.g.h.i.j.i.k.l.m.n.o.p.q.r.s.t.. ",
+" . u.v.w.;.x.y.z.t.A.t.A.B.C.D.E.F.G.H.I.J.. ",
+" . . . . . . . . . . . . . . . . . . . . ",
+" . K.L.M.N.N.N.N.N.O.P.L.Q.P.R.R.R.G G . ",
+" . . . . . . . . . . . . . . . . . . ",
+" "};
diff --git a/lisp/toolbar/right_arrow.pbm b/lisp/toolbar/right_arrow.pbm
index 583f2bd13fa..cd32579c6bd 100644
--- a/lisp/toolbar/right_arrow.pbm
+++ b/lisp/toolbar/right_arrow.pbm
Binary files differ
diff --git a/lisp/toolbar/right_arrow.xpm b/lisp/toolbar/right_arrow.xpm
index 9e0b14749a8..da8156879d6 100644
--- a/lisp/toolbar/right_arrow.xpm
+++ b/lisp/toolbar/right_arrow.xpm
@@ -1,35 +1,67 @@
/* XPM */
static char * right_arrow_xpm[] = {
-"24 24 9 1",
+"24 24 41 1",
" c None",
-". c #020202",
-"+ c #1A1A1A",
-"@ c #779D6D",
-"# c #88AE80",
-"$ c #97B78B",
-"% c #9EBA92",
-"& c #E9EFE8",
-"* c #3C5936",
+". c #000000",
+"+ c #8CA782",
+"@ c #B1CDAE",
+"# c #77A16E",
+"$ c #B4CEB1",
+"% c #ACC8A9",
+"& c #709867",
+"* c #C1D6BD",
+"= c #BDD3B8",
+"- c #BFD4BB",
+"; c #C2D7BE",
+"> c #B0CAAD",
+", c #B2CBB0",
+"' c #AAC7A8",
+") c #0F1308",
+"! c #AEC5A8",
+"~ c #AEC8AD",
+"{ c #ABC7A8",
+"] c #AAC6A7",
+"^ c #A8C6A5",
+"/ c #ADC8AD",
+"( c #A8C7A8",
+"_ c #A5C4A3",
+": c #7F9F76",
+"< c #A6BFA0",
+"[ c #ABC7AA",
+"} c #A7C5A4",
+"| c #A9C7A6",
+"1 c #AFC8AD",
+"2 c #A4C3A2",
+"3 c #6B9060",
+"4 c #778E6F",
+"5 c #698D60",
+"6 c #6B9063",
+"7 c #445B2C",
+"8 c #6B8661",
+"9 c #5B7950",
+"0 c #6C8562",
+"a c #65815C",
+"b c #506B46",
" ",
" ",
" ",
-" ",
-" ",
-" .. ",
-" .&.. ",
-" .&&&.. ",
-" .&&&&&.. ",
-" .&&&&&&&.. ",
-" .&&&&&&&&&+. ",
-" +&&&&&&&&&&%.. ",
-" .%#######@@*.. ",
-" .%#####@@*.. ",
-" .%###@@*.. ",
-" .$#@@*.. ",
-" .#@*.. ",
-" .*.. ",
-" .. ",
-" ",
+" . ",
+" .. ",
+" .+. ",
+" .@#. ",
+" ........$%&. ",
+" .*=-;;;;>,'&) ",
+" .!~{{{]^'/(_:. ",
+" .<[^}^|{%'{123. ",
+" .45666666666657. ",
+" .8999999999997. ",
+" .099999999997. ",
+" .abbbbbb9997. ",
+" ........b97. ",
+" .b7. ",
+" .7. ",
+" .. ",
+" . ",
" ",
" ",
" ",
diff --git a/lisp/toolbar/save.pbm b/lisp/toolbar/save.pbm
index e153a144432..b69576096bf 100644
--- a/lisp/toolbar/save.pbm
+++ b/lisp/toolbar/save.pbm
Binary files differ
diff --git a/lisp/toolbar/save.xpm b/lisp/toolbar/save.xpm
index 8bdb36315be..cfa651dfaf3 100644
--- a/lisp/toolbar/save.xpm
+++ b/lisp/toolbar/save.xpm
@@ -1,35 +1,247 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 5 1",
-" c #01be01be01be",
-". c #62dd62dd62dd",
-"X c Gray62",
-"o c #e625e625e625",
-"O c None",
-/* pixels */
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOO OOOOOOOOO",
-"OOOOOOOOOOO X. OOOOOOOO",
-"OOOOOOOOO oXoX OOOOOOOO",
-"OOOOOOO oXoooXX OOOOOOO",
-"OOOOO oXoooooo. OOOOOOO",
-"OOO XoooooooooX OOOOOO",
-"OO XooooooooooooX OOOOOO",
-"OO .XoooooooooooX. OOOOO",
-"OOO XooooooooooXXX OOOOO",
-"OOO .XoooooooXX..X. OOOO",
-"OOOO XoooooXX...X.X OOOO",
-"OOOO .XooXX.Xoo.X.X. OOO",
-"OOOOO XXX.oooooX.X. OOO",
-"OOOOO .XXoo.ooooXX OOO",
-"OOOOOO XX.o XooX. OOOOO",
-"OOOOOO .XXooXoX OOOOOOO",
-"OOOOOOO .X.oX OOOOOOOOO",
-"OOOOOOOO OOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO"
-};
+static char * save_xpm[] = {
+"24 24 220 2",
+" c None",
+". c #000000",
+"+ c #C3D7F4",
+"@ c #A9CDE5",
+"# c #75757A",
+"$ c #EFC5BB",
+"% c #F1C8BE",
+"& c #F0C6BC",
+"* c #EEBCB2",
+"= c #EEBEB5",
+"- c #EEC1B8",
+"; c #EDBFB6",
+"> c #E9B7AD",
+", c #E9B8AF",
+"' c #E9B9B1",
+") c #E5BFBA",
+"! c #737277",
+"~ c #B3CDE3",
+"{ c #A1BED6",
+"] c #BBD6E8",
+"^ c #8AAAC5",
+"/ c #605F68",
+"( c #E08D7E",
+"_ c #E0826E",
+": c #E0806E",
+"< c #DC7A68",
+"[ c #DC8171",
+"} c #DA7868",
+"| c #D48173",
+"1 c #D47D6E",
+"2 c #CE7265",
+"3 c #CF7264",
+"4 c #CE7567",
+"5 c #C4675B",
+"6 c #C36558",
+"7 c #626169",
+"8 c #87A3B7",
+"9 c #567187",
+"0 c #BAD5E9",
+"a c #88A7C3",
+"b c #686670",
+"c c #C8817B",
+"d c #CB7C74",
+"e c #CB7A73",
+"f c #CB7B73",
+"g c #CC7C72",
+"h c #CB7D73",
+"i c #BF6B64",
+"j c #CC7A70",
+"k c #C16A62",
+"l c #CC7C73",
+"m c #C2655B",
+"n c #C36459",
+"o c #BA6C6A",
+"p c #819EB6",
+"q c #547086",
+"r c #B6D3E7",
+"s c #87ABC1",
+"t c #737373",
+"u c #FFFFFF",
+"v c #83A0B8",
+"w c #526C80",
+"x c #B9D3E7",
+"y c #85A4BF",
+"z c #4F697C",
+"A c #B9D3E6",
+"B c #84A3BF",
+"C c #CECECE",
+"D c #CDCDCD",
+"E c #BFBFBF",
+"F c #88A4BB",
+"G c #486276",
+"H c #B7D2E7",
+"I c #82A0BB",
+"J c #636363",
+"K c #465E70",
+"L c #B5CAE5",
+"M c #7FA2B9",
+"N c #87A3BA",
+"O c #455C6D",
+"P c #AECCE5",
+"Q c #7DA0B6",
+"R c #C5C5C5",
+"S c #546069",
+"T c #B0D1E4",
+"U c #83A1B6",
+"V c #735B5B",
+"W c #515C64",
+"X c #AACEE3",
+"Y c #7B9BB2",
+"Z c #7A8E9A",
+"` c #7A7A7A",
+" . c #6B6F72",
+".. c #6F6F6F",
+"+. c #696969",
+"@. c #6F777E",
+"#. c #86A2B9",
+"$. c #3A515D",
+"%. c #A9C9E2",
+"&. c #7494AF",
+"*. c #829FB7",
+"=. c #7F9DB6",
+"-. c #7E9CB5",
+";. c #7998B2",
+">. c #85A1B8",
+",. c #8CA7BD",
+"'. c #8AA5BB",
+"). c #364A59",
+"!. c #ABC4E2",
+"~. c #7294AD",
+"{. c #6F90AC",
+"]. c #7192AE",
+"^. c #414A4E",
+"/. c #424A51",
+"(. c #525B63",
+"_. c #626F79",
+":. c #5F6C76",
+"<. c #5C6971",
+"[. c #5A666F",
+"}. c #58636B",
+"|. c #57636A",
+"1. c #3B5360",
+"2. c #39424B",
+"3. c #7897B3",
+"4. c #A4B9CB",
+"5. c #364853",
+"6. c #AAC9E2",
+"7. c #7091AA",
+"8. c #6F8FA7",
+"9. c #4A5359",
+"0. c #97938C",
+"a. c #DFDDDA",
+"b. c #E3E1DE",
+"c. c #EBEAE8",
+"d. c #EAE9E7",
+"e. c #CFCEC9",
+"f. c #C9C6C0",
+"g. c #9B968E",
+"h. c #566168",
+"i. c #4B657A",
+"j. c #54738C",
+"k. c #AAC6DD",
+"l. c #34464E",
+"m. c #AAC9E1",
+"n. c #6C8EA6",
+"o. c #6C8CA4",
+"p. c #40474D",
+"q. c #DAD8D3",
+"r. c #E7E6E2",
+"s. c #67655E",
+"t. c #524F47",
+"u. c #D9D7D4",
+"v. c #C7C5BF",
+"w. c #C0BCB5",
+"x. c #B8B3AB",
+"y. c #434C54",
+"z. c #4D697F",
+"A. c #4F6F84",
+"B. c #B3CADC",
+"C. c #313E49",
+"D. c #A8C8E1",
+"E. c #6B8DA6",
+"F. c #728FA4",
+"G. c #E2E1DD",
+"H. c #F0EFEC",
+"I. c #CDCAC6",
+"J. c #C2BFB9",
+"K. c #CAC6C0",
+"L. c #DCDAD7",
+"M. c #4B555D",
+"N. c #4E697F",
+"O. c #BACCDC",
+"P. c #A4C4DE",
+"Q. c #698BA3",
+"R. c #708AA1",
+"S. c #383E43",
+"T. c #E0DEDA",
+"U. c #514E46",
+"V. c #4F4C44",
+"W. c #C7C4BE",
+"X. c #CBC8C2",
+"Y. c #E1E0DC",
+"Z. c #E9E8E6",
+"`. c #475158",
+" + c #4E6879",
+".+ c #4D6C80",
+"++ c #A3C3DB",
+"@+ c #383F43",
+"#+ c #778999",
+"$+ c #6E899E",
+"%+ c #65859C",
+"&+ c #33383C",
+"*+ c #D7D4D0",
+"=+ c #D6D4D0",
+"-+ c #4E4A43",
+";+ c #4D4942",
+">+ c #D1CEC9",
+",+ c #E6E5E2",
+"'+ c #EDECEA",
+")+ c #454F55",
+"!+ c #486173",
+"~+ c #4D6678",
+"{+ c #A1C1DA",
+"]+ c #373C40",
+"^+ c #0C0D0F",
+"/+ c #4E5E6A",
+"(+ c #5B6E7C",
+"_+ c #4F5B62",
+":+ c #A4A099",
+"<+ c #CCC9C3",
+"[+ c #D7D5D1",
+"}+ c #E4E2E0",
+"|+ c #DDDBD7",
+"1+ c #B8B5B0",
+"2+ c #3E474D",
+"3+ c #4A6176",
+"4+ c #4A6070",
+"5+ c #9BC3D8",
+"6+ c #363C41",
+"7+ c #28323E",
+" ",
+" . . . . . . . . . . . . . . . . . . . ",
+" . + @ # $ % & * = - ; > , > , ' ) ! ~ { . ",
+" . ] ^ / ( _ : < [ } | 1 2 3 4 5 6 7 8 9 . ",
+" . 0 a b c d e f g h i j k l m n o b p q . ",
+" . r s t u u u u u u u u u u u u u t v w . ",
+" . x y t u u u u u u u u u u u u u t v z . ",
+" . A B t C D D D D D D D D D D D E t F G . ",
+" . H I J u u u u u u u u u u u u u t F K . ",
+" . L M t u u u u u u u u u u u u u t N O . ",
+" . P Q t C D D D D D D D D D D D R t N S . ",
+" . T U V u u u u u u u u u u u u u t v W . ",
+" . X Y Z ` t t t t t ...t t t t +.@.#.$.. ",
+" . %.&.p v #.*.=.-.*.;.#.>.>.N *.,.v '.).. ",
+" . !.~.{.].^./.(._.:.<.[.}.|.(.1.2.3.4.5.. ",
+" . 6.7.8.9.0.a.b.c.c.d.a.e.f.g.h.i.j.k.l.. ",
+" . m.n.o.p.q.r.s.t.t.u.v.w.x.e.y.z.A.B.C.. ",
+" . D.E.F.p.G.H.s.t.t.I.J.w.K.L.M.N.A.O.C.. ",
+" . P.Q.R.S.T.c.U.V.V.W.w.X.Y.Z.`. +.+++@+. ",
+" . #+$+%+&+*+=+-+;+;+w.>+,+'+,+)+!+~+{+]+. ",
+" ^+/+(+_+:+w.x.<+<+[+}+d.|+1+2+3+4+5+6+. ",
+" . . . . . . . . . . . . . . . . 7+. ",
+" ",
+" "};
diff --git a/lisp/toolbar/saveas.pbm b/lisp/toolbar/saveas.pbm
index 9a9022e058e..6bf6b8f25eb 100644
--- a/lisp/toolbar/saveas.pbm
+++ b/lisp/toolbar/saveas.pbm
Binary files differ
diff --git a/lisp/toolbar/saveas.xpm b/lisp/toolbar/saveas.xpm
index 87d9174f67f..2830b06c928 100644
--- a/lisp/toolbar/saveas.xpm
+++ b/lisp/toolbar/saveas.xpm
@@ -1,35 +1,289 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 5 1",
-" c #01be01be01be",
-". c #62dd62dd62dd",
-"X c Gray62",
-"o c #e625e625e625",
-"O c None",
-/* pixels */
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOO OOOO",
-"OOOOOOOOOOOOOOOOOO X OOO",
-"OOOOOOOOOOOOO OO X. OOO",
-"OOOOOOOOOOO X. X. OOOO",
-"OOOOOOOOO oXoX X. OOOOO",
-"OOOOOOO oXoOo X. OOOOOO",
-"OOOOO oXoOoO X. OOOOOOO",
-"OOO XooOOoO X. OOOOOO",
-"OO XooOoXoO X. oX OOOOOO",
-"OO .XooXoO X. OoX. OOOOO",
-"OOO XooXOX. ooXXX OOOOO",
-"OOO .XoOX ooXX..X. OOOO",
-"OOOO XoOXooXX...X.X OOOO",
-"OOOO .XooXX.Xoo.X.X. OOO",
-"OOOOO XXX.oooooX.X. OOO",
-"OOOOO .XXoo.ooooXX OOO",
-"OOOOOO XX.o XooX. OOOOO",
-"OOOOOO .XXooXoX OOOOOOO",
-"OOOOOOO .X.oX OOOOOOOOO",
-"OOOOOOOO OOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO"
-};
+static char * saveas_xpm[] = {
+"24 24 262 2",
+" c None",
+". c #000000",
+"+ c #FBE73B",
+"@ c #F2B64D",
+"# c #FCEB3D",
+"$ c #F7B544",
+"% c #5D502C",
+"& c #C3D7F4",
+"* c #A9CDE5",
+"= c #75757A",
+"- c #EFC5BB",
+"; c #F1C8BE",
+"> c #F0C6BC",
+", c #EEBCB2",
+"' c #EEBEB5",
+") c #EEC1B8",
+"! c #EDBFB6",
+"~ c #E8B6AC",
+"{ c #FCE93B",
+"] c #F7B545",
+"^ c #6C5F34",
+"/ c #434345",
+"( c #92A7B9",
+"_ c #96B1C7",
+": c #BBD6E8",
+"< c #8AAAC5",
+"[ c #605F68",
+"} c #E08D7E",
+"| c #E0826E",
+"1 c #E0806E",
+"2 c #DC7A68",
+"3 c #DC8171",
+"4 c #DA7868",
+"5 c #D38072",
+"6 c #FAE43A",
+"7 c #F4B244",
+"8 c #615030",
+"9 c #783E35",
+"0 c #4D4C52",
+"a c #7790A2",
+"b c #526D82",
+"c c #BAD5E9",
+"d c #88A7C3",
+"e c #686670",
+"f c #C8817B",
+"g c #CB7C74",
+"h c #CB7A73",
+"i c #CB7B73",
+"j c #CC7C72",
+"k c #CA7C72",
+"l c #F9DF39",
+"m c #F3AF42",
+"n c #614F2F",
+"o c #8F4941",
+"p c #945554",
+"q c #5B5A62",
+"r c #7B97AE",
+"s c #536F84",
+"t c #B6D3E7",
+"u c #87ABC1",
+"v c #737373",
+"w c #FFFFFF",
+"x c #FEFEFE",
+"y c #F9DC38",
+"z c #EFB44D",
+"A c #665A32",
+"B c #BBBBBB",
+"C c #CDCDCD",
+"D c #E4E4E4",
+"E c #6E6E6E",
+"F c #819EB6",
+"G c #526C80",
+"H c #B9D3E7",
+"I c #85A4BF",
+"J c #F8D837",
+"K c #F0A93F",
+"L c #655930",
+"M c #BABABA",
+"N c #CCCCCC",
+"O c #E5E5E5",
+"P c #F7F7F7",
+"Q c #727272",
+"R c #83A0B8",
+"S c #4F697C",
+"T c #B9D3E6",
+"U c #84A3BF",
+"V c #CECECE",
+"W c #F6D236",
+"X c #EDA43E",
+"Y c #5C5130",
+"Z c #949494",
+"` c #A3A3A3",
+" . c #B7B7B7",
+".. c #C6C6C6",
+"+. c #BDBDBD",
+"@. c #88A4BB",
+"#. c #486276",
+"$. c #B7D2E7",
+"%. c #82A0BB",
+"&. c #636363",
+"*. c #FDFDFD",
+"=. c #D7AE74",
+"-. c #61562F",
+";. c #465E70",
+">. c #B5CAE5",
+",. c #7FA2B9",
+"'. c #4F4115",
+"). c #87A3BA",
+"!. c #455C6D",
+"~. c #AECCE5",
+"{. c #7DA0B6",
+"]. c #CBCBCB",
+"^. c #9B9B9B",
+"/. c #9C9C9C",
+"(. c #A7A7A7",
+"_. c #B8B8B8",
+":. c #C5C5C5",
+"<. c #546069",
+"[. c #B0D1E4",
+"}. c #83A1B6",
+"|. c #735B5B",
+"1. c #F0F0F0",
+"2. c #D9D9D9",
+"3. c #D3D3D3",
+"4. c #E1E1E1",
+"5. c #EDEDED",
+"6. c #F8F8F8",
+"7. c #515C64",
+"8. c #AACEE3",
+"9. c #7B9BB2",
+"0. c #7A8E9A",
+"a. c #7A7A7A",
+"b. c #707070",
+"c. c #6C6C6C",
+"d. c #6F6F6F",
+"e. c #6A6E71",
+"f. c #696969",
+"g. c #6F777E",
+"h. c #86A2B9",
+"i. c #3A515D",
+"j. c #A9C9E2",
+"k. c #7494AF",
+"l. c #7E9BB4",
+"m. c #7D9AB3",
+"n. c #7998B2",
+"o. c #85A1B8",
+"p. c #829FB7",
+"q. c #8CA7BD",
+"r. c #8AA5BB",
+"s. c #364A59",
+"t. c #ABC4E2",
+"u. c #7294AD",
+"v. c #6F90AC",
+"w. c #7192AE",
+"x. c #414A4E",
+"y. c #424A51",
+"z. c #525B63",
+"A. c #626F79",
+"B. c #5F6C76",
+"C. c #5C6971",
+"D. c #5A666F",
+"E. c #58636B",
+"F. c #57636A",
+"G. c #3B5360",
+"H. c #39424B",
+"I. c #7897B3",
+"J. c #A4B9CB",
+"K. c #364853",
+"L. c #AAC9E2",
+"M. c #7091AA",
+"N. c #6F8FA7",
+"O. c #4A5359",
+"P. c #97938C",
+"Q. c #DFDDDA",
+"R. c #E3E1DE",
+"S. c #EBEAE8",
+"T. c #EAE9E7",
+"U. c #CFCEC9",
+"V. c #C9C6C0",
+"W. c #9B968E",
+"X. c #566168",
+"Y. c #4B657A",
+"Z. c #54738C",
+"`. c #AAC6DD",
+" + c #34464E",
+".+ c #AAC9E1",
+"++ c #6C8EA6",
+"@+ c #6C8CA4",
+"#+ c #40474D",
+"$+ c #DAD8D3",
+"%+ c #E7E6E2",
+"&+ c #67655E",
+"*+ c #524F47",
+"=+ c #D9D7D4",
+"-+ c #C7C5BF",
+";+ c #C0BCB5",
+">+ c #B8B3AB",
+",+ c #434C54",
+"'+ c #4D697F",
+")+ c #4F6F84",
+"!+ c #B3CADC",
+"~+ c #313E49",
+"{+ c #A8C8E1",
+"]+ c #6B8DA6",
+"^+ c #728FA4",
+"/+ c #E2E1DD",
+"(+ c #F0EFEC",
+"_+ c #CDCAC6",
+":+ c #C2BFB9",
+"<+ c #CAC6C0",
+"[+ c #DCDAD7",
+"}+ c #4B555D",
+"|+ c #4E697F",
+"1+ c #BACCDC",
+"2+ c #A4C4DE",
+"3+ c #698BA3",
+"4+ c #708AA1",
+"5+ c #383E43",
+"6+ c #E0DEDA",
+"7+ c #514E46",
+"8+ c #4F4C44",
+"9+ c #C7C4BE",
+"0+ c #CBC8C2",
+"a+ c #E1E0DC",
+"b+ c #E9E8E6",
+"c+ c #475158",
+"d+ c #4E6879",
+"e+ c #4D6C80",
+"f+ c #A3C3DB",
+"g+ c #383F43",
+"h+ c #778999",
+"i+ c #6E899E",
+"j+ c #65859C",
+"k+ c #33383C",
+"l+ c #D7D4D0",
+"m+ c #D6D4D0",
+"n+ c #4E4A43",
+"o+ c #4D4942",
+"p+ c #D1CEC9",
+"q+ c #E6E5E2",
+"r+ c #EDECEA",
+"s+ c #454F55",
+"t+ c #486173",
+"u+ c #4D6678",
+"v+ c #A1C1DA",
+"w+ c #373C40",
+"x+ c #0C0D0F",
+"y+ c #4E5E6A",
+"z+ c #5B6E7C",
+"A+ c #4F5B62",
+"B+ c #A4A099",
+"C+ c #CCC9C3",
+"D+ c #D7D5D1",
+"E+ c #E4E2E0",
+"F+ c #DDDBD7",
+"G+ c #B8B5B0",
+"H+ c #3E474D",
+"I+ c #4A6176",
+"J+ c #4A6070",
+"K+ c #9BC3D8",
+"L+ c #363C41",
+"M+ c #28323E",
+" . . ",
+" . + @ . ",
+" . . . . . . . . . . . . . # $ % . . . ",
+" . & * = - ; > , ' ) ! ~ . { ] ^ . / ( _ . ",
+" . : < [ } | 1 2 3 4 5 . 6 7 8 . 9 0 a b . ",
+" . c d e f g h i j k . l m n . o p q r s . ",
+" . t u v w w w w x . y z A . B C D E F G . ",
+" . H I v w w w x . J K L . M N O P Q R S . ",
+" . T U v V C N . W X Y . Z ` ...+.v @.#.. ",
+" . $.%.&.w w *.. =.-.. M N D P *.w v @.;.. ",
+" . >.,.v w x . '.. . M N D P *.w w v ).!.. ",
+" . ~.{.v V ].. . ^./.(._...].C C :.v ).<.. ",
+" . [.}.|.w *.1.2.3.4.5.6.x w w w w v R 7.. ",
+" . 8.9.0.a.Q b.c.c.d.e.E v v v v f.g.h.i.. ",
+" . j.k.F R h.F l.m.F n.h.o.o.).p.q.R r.s.. ",
+" . t.u.v.w.x.y.z.A.B.C.D.E.F.z.G.H.I.J.K.. ",
+" . L.M.N.O.P.Q.R.S.S.T.Q.U.V.W.X.Y.Z.`. +. ",
+" . .+++@+#+$+%+&+*+*+=+-+;+>+U.,+'+)+!+~+. ",
+" . {+]+^+#+/+(+&+*+*+_+:+;+<+[+}+|+)+1+~+. ",
+" . 2+3+4+5+6+S.7+8+8+9+;+0+a+b+c+d+e+f+g+. ",
+" . h+i+j+k+l+m+n+o+o+;+p+q+r+q+s+t+u+v+w+. ",
+" x+y+z+A+B+;+>+C+C+D+E+T.F+G+H+I+J+K+L+. ",
+" . . . . . . . . . . . . . . . . M+. ",
+" "};
diff --git a/lisp/toolbar/search.pbm b/lisp/toolbar/search.pbm
index 9336eea6874..0e8a15e6a2e 100644
--- a/lisp/toolbar/search.pbm
+++ b/lisp/toolbar/search.pbm
Binary files differ
diff --git a/lisp/toolbar/search.xpm b/lisp/toolbar/search.xpm
index ff8732201e4..ad6300528e9 100644
--- a/lisp/toolbar/search.xpm
+++ b/lisp/toolbar/search.xpm
@@ -1,38 +1,234 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 8 1",
-" c #011801180102",
-". c #464646463e3e",
-"X c #5c5c5c5c57a0",
-"o c #878787877979",
-"O c #a910a91097af",
-"+ c #ce5ace5ab851",
-"@ c #e79de79dd134",
-"# c None",
-/* pixels */
-"########################",
-"########################",
-"############# ##########",
-"########### O #########",
-"######### O@@.#########",
-"####### O@@@@@ ########",
-"##### O+@@@@@@O #######",
-"#### XX@++@@@@@@.#######",
-"#### @.O+@@@@@@@@ ######",
-"#### @@.++@@@@@@@O #####",
-"#### @@.o+O. .+@@ #####",
-"#### @XO+O.O++o.+@@ ####",
-"#### O+@.O@@+Oo.@@+ ###",
-"#### X@@@ +#+OOO @@@@ ##",
-"#### O@@@ +@OOOo @@@o ##",
-"##### @@@.oOOOoX.@@ ###",
-"##### O@@O.oOOX @ #####",
-"######X@@@O. .X ######",
-"###### @@@@@@@+ #####",
-"####### @@@@@O ## ####",
-"####### O@@+. #### ###",
-"######## @O ####### ###",
-"######### #############",
-"########################"
-};
+static char * search_xpm[] = {
+"24 24 207 2",
+" c None",
+". c #000000",
+"+ c #D3D3D3",
+"@ c #F6F6F6",
+"# c #FFFFFF",
+"$ c #F9F9F9",
+"% c #DADADA",
+"& c #585858",
+"* c #C7C7C7",
+"= c #D1D1D1",
+"- c #D6D6D6",
+"; c #FEFEFE",
+"> c #FDFDFD",
+", c #C0C0C0",
+"' c #E1E1E1",
+") c #F0F0F0",
+"! c #9B9B9B",
+"~ c #FCFCFB",
+"{ c #FBFBFB",
+"] c #AFAFAE",
+"^ c #E9E9E9",
+"/ c #DFDFDF",
+"( c #8F8F8F",
+"_ c #FAFAF9",
+": c #F9F9F8",
+"< c #A4A4A3",
+"[ c #F4F4F4",
+"} c #CFCFCF",
+"| c #A2A2A2",
+"1 c #B8B8B8",
+"2 c #47473F",
+"3 c #0A0A09",
+"4 c #4B4B43",
+"5 c #B4B4B3",
+"6 c #F7F6F5",
+"7 c #9E9E9E",
+"8 c #A9A9A8",
+"9 c #34342E",
+"0 c #9D9D8D",
+"a c #CFCFB9",
+"b c #C4C4AF",
+"c c #8D8D7F",
+"d c #353530",
+"e c #ACACAA",
+"f c #F1F0EF",
+"g c #DEDDDC",
+"h c #D3D2D0",
+"i c #B7B7B5",
+"j c #9F9E9D",
+"k c #706F6F",
+"l c #65625A",
+"m c #46463F",
+"n c #9C9C8C",
+"o c #E2E2D0",
+"p c #EDEDE7",
+"q c #C0C0AC",
+"r c #B2B29F",
+"s c #828274",
+"t c #4C4C44",
+"u c #E4E4E2",
+"v c #E1E1DF",
+"w c #DAD9D7",
+"x c #D8D8D6",
+"y c #CDCCCA",
+"z c #AFAEAC",
+"A c #88847B",
+"B c #F8F8F7",
+"C c #090908",
+"D c #D5D5BF",
+"E c #FBFBFA",
+"F c #C3C3AE",
+"G c #B5B5A2",
+"H c #A6A695",
+"I c #9C9C8F",
+"J c #080807",
+"K c #CFCFCD",
+"L c #E3E2E0",
+"M c #ECEBE9",
+"N c #E9E8E6",
+"O c #D5D4D3",
+"P c #C4C3C2",
+"Q c #8F8A81",
+"R c #F6F5F4",
+"S c #F3F3F1",
+"T c #090909",
+"U c #CACAB5",
+"V c #DDDDD0",
+"W c #B7B7A4",
+"X c #AAAA98",
+"Y c #9B9B8B",
+"Z c #AEAEA3",
+"` c #BBBAB9",
+" . c #E8E7E5",
+".. c #E5E4E2",
+"+. c #E4E3E0",
+"@. c #D2D1CE",
+"#. c #8D887E",
+"$. c #F4F3F2",
+"%. c #F0EFEE",
+"&. c #474740",
+"*. c #929283",
+"=. c #BABAA7",
+"-. c #ADAD9B",
+";. c #9F9F8E",
+">. c #ACACA1",
+",. c #CFCFCB",
+"'. c #4C4C45",
+"). c #B3B2B1",
+"!. c #E2E1DE",
+"~. c #E1DFDC",
+"{. c #979288",
+"]. c #949493",
+"^. c #34342F",
+"/. c #878779",
+"(. c #A0A090",
+"_. c #AEAEA2",
+":. c #C3C3BE",
+"<. c #010101",
+"[. c #B1B0AF",
+"}. c #D2D1CF",
+"|. c #A49E93",
+"1. c #F0F0EE",
+"2. c #EDEDEB",
+"3. c #DDDDDB",
+"4. c #898988",
+"5. c #414141",
+"6. c #737271",
+"7. c #A4A3A1",
+"8. c #DFDEDB",
+"9. c #E2E0DD",
+"0. c #E1E0DC",
+"a. c #E0DFDB",
+"b. c #A19C90",
+"c. c #E1E0DE",
+"d. c #CBCAC9",
+"e. c #B2B1B0",
+"f. c #A3A2A1",
+"g. c #9D9C9A",
+"h. c #9E9D9C",
+"i. c #9F9F9D",
+"j. c #ABAAA7",
+"k. c #DCDBD7",
+"l. c #DEDDD9",
+"m. c #DDDCD8",
+"n. c #A19B90",
+"o. c #EBEAE8",
+"p. c #E6E5E3",
+"q. c #C8C7C4",
+"r. c #B6B6B3",
+"s. c #B0AFAD",
+"t. c #B3B2B0",
+"u. c #747371",
+"v. c #9D9C99",
+"w. c #DAD9D5",
+"x. c #E7E6E3",
+"y. c #E6E5E2",
+"z. c #E3E2DF",
+"A. c #DBDAD7",
+"B. c #D4D3D0",
+"C. c #D0CFCB",
+"D. c #D1CFCC",
+"E. c #D1D0CC",
+"F. c #C9C8C4",
+"G. c #6B6B69",
+"H. c #CECDC9",
+"I. c #D6D4D0",
+"J. c #9F998D",
+"K. c #E3E2DE",
+"L. c #E4E2DF",
+"M. c #DFDEDA",
+"N. c #D5D4D0",
+"O. c #C0BFBC",
+"P. c #7B7A78",
+"Q. c #BCBAB6",
+"R. c #CECCC8",
+"S. c #9D978C",
+"T. c #EDEDED",
+"U. c #E1E0DD",
+"V. c #E2E1DD",
+"W. c #DBDAD6",
+"X. c #BBB9B6",
+"Y. c #A6A4A1",
+"Z. c #9E9C99",
+"`. c #ACABA7",
+" + c #C7C5C2",
+".+ c #9B9589",
+"++ c #E1DFDB",
+"@+ c #E0DEDA",
+"#+ c #DEDCD8",
+"$+ c #DAD8D4",
+"%+ c #BDBCB8",
+"&+ c #ACABA8",
+"*+ c #B2B1AD",
+"=+ c #C6C4C0",
+"-+ c #999388",
+";+ c #999891",
+">+ c #A39E92",
+",+ c #A39D92",
+"'+ c #A39D91",
+")+ c #A29C90",
+"!+ c #A19B8F",
+"~+ c #9D978B",
+"{+ c #989286",
+"]+ c #918C82",
+"^+ c #938D83",
+"/+ c #979286",
+"(+ c #666258",
+" ",
+" . . . . . . . . . . . . . ",
+" . + @ # # # # # # # # $ % & . ",
+" . @ # # # # # # # # # # * = - . ",
+" . # # # # # # # ; # ; > , ' ) ! . ",
+" . # # # # # ; > ~ > ~ { ] ^ # / ( . ",
+" . # # # ; > ~ { _ { _ : < ) # [ } | . ",
+" . # ; > ~ 1 2 3 3 4 5 6 7 . . . . . . . ",
+" . # ~ { 8 9 0 a b c d e f g h i j k l . ",
+" . # _ : m n o p q r s t u v w x y z A . ",
+" . # B 6 C D E F G H I J K L M N O P Q . ",
+" . # R S T U V W X Y Z 3 ` w ...+.@.#.. ",
+" . # $.%.&.*.=.-.;.>.,.'.).h !.+.!.~.{.. ",
+" . # $.%.].^./.(._.:.<.<.[.}.!.+.!.~.|.. ",
+" . # 1.2.3.4.4 3 3 5.6.<.<.7.8.9.0.a.b.. ",
+" . # 2.M c.d.e.f.g.h.i.<.<.<.j.k.l.m.n.. ",
+" . # o.N p.w q.r.z s.t.u.. <.<.v.w.k.n.. ",
+" . # x.y.y.z.A.B.C.D.E.F.G.<.<.<.H.I.J.. ",
+" . $ +.z.K.L.K.a.a.M.M.N.O.P.<.<.Q.R.S.. ",
+" . T.U.~.0.a.V.a.0.a.0.W.E.X.Y.Z.`. +.+. ",
+" . = ++@+M.l.a.l.@+l.@+#+$+R.%+&+*+=+-+. ",
+" . ;+>+|.,+'+,+b.)+b.)+!+n.~+{+]+^+/+(+. ",
+" . . . . . . . . . . . . . . . . . . ",
+" "};
diff --git a/lisp/toolbar/spell.pbm b/lisp/toolbar/spell.pbm
index c641babe8ed..39a00c8946a 100644
--- a/lisp/toolbar/spell.pbm
+++ b/lisp/toolbar/spell.pbm
Binary files differ
diff --git a/lisp/toolbar/spell.xpm b/lisp/toolbar/spell.xpm
index a2c2282b48b..b53f4510602 100644
--- a/lisp/toolbar/spell.xpm
+++ b/lisp/toolbar/spell.xpm
@@ -1,35 +1,64 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 5 1",
-" c Gray0",
-". c #41415b5b3939",
-"X c #4c2f6b4e42d1",
-"o c #5fe086865454",
-"O c None",
-/* pixels */
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOO OO OOO OOOOOOOO",
-"OOO OO O OO O OO OOOOOOO",
-"OOO O OO OOOOOOOOOO",
-"OOO OO O OO O OO OOOOOOO",
-"OOO OO O OOO OOOO OO",
-"OOOOOOOOOOOOOOOOOOO OOO",
-"OOOOOOOOOOO OOOOO OOOO",
-"OOOOOOOOOOO X OOO . OOOO",
-"OOOOOOOOOOOO X O X OOOOO",
-"OOOOOOOOOOOO Xo o. OOOOO",
-"OOOOOOOOOOOOO XoX OOOOOO",
-"OOOOOOOOOOOOO Xo. OOOOOO",
-"OOOOOOOOOOOOOO X OOOOOOO",
-"OOOOOOOOOOOOOO X OOOOOOO",
-"OOOOOOOOOOOOOOO OOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO"
-};
+static char * spell_xpm[] = {
+"24 24 37 1",
+" c None",
+". c #000000",
+"+ c #8BBB8C",
+"@ c #ABD0AC",
+"# c #1A3B1A",
+"$ c #8ABA88",
+"% c #B4D5B4",
+"& c #70A770",
+"* c #132C13",
+"= c #77A676",
+"- c #2D2D2D",
+"; c #CBDFCB",
+"> c #6FAE6E",
+", c #A8CBA6",
+"' c #6D9D6C",
+") c #D0E4D0",
+"! c #6FAF6F",
+"~ c #587055",
+"{ c #B8D6B8",
+"] c #5B9159",
+"^ c #D4E4D4",
+"/ c #67AF67",
+"( c #5D905B",
+"_ c #9FC59D",
+": c #93BE92",
+"< c #B5D1B5",
+"[ c #67AF68",
+"} c #63A261",
+"| c #BBD6BA",
+"1 c #82B881",
+"2 c #75AF74",
+"3 c #6B8868",
+"4 c #9DC39D",
+"5 c #7DB17B",
+"6 c #6BA368",
+"7 c #485C46",
+"8 c #89BA88",
+" ",
+" ",
+" ",
+" ",
+" ... .... ... ",
+" .. . .. . .. . ",
+" .. . .... .. ",
+" ..... .. . .. ",
+" .. . .. . .. . . ",
+" .. . .... ... ... ",
+" .+. ",
+" .. .@# ",
+" .$. .%&. ",
+" *=. -;>. ",
+" .,'. .)!~. ",
+" .{].^/(. ",
+" ._:<[}~. ",
+" .|123. ",
+" .4567. ",
+" .83. ",
+" .37. ",
+" .. ",
+" ",
+" "};
diff --git a/lisp/toolbar/tool-bar.el b/lisp/toolbar/tool-bar.el
index 425789eb80e..bf1c229ccb9 100644
--- a/lisp/toolbar/tool-bar.el
+++ b/lisp/toolbar/tool-bar.el
@@ -96,7 +96,8 @@ PROPS are additional items to add to the menu item specification. See
Info node `(elisp)Tool Bar'. Items are added from left to right.
ICON is the base name of a file containing the image to use. The
-function will first try to use ICON.xpm, then ICON.pbm, and finally
+function will first try to use lc-ICON.xpm if display-color-cells
+is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
ICON.xbm, using `find-image'.
Use this function only to make bindings in the global value of `tool-bar-map'.
@@ -112,24 +113,24 @@ PROPS are additional items to add to the menu item specification. See
Info node `(elisp)Tool Bar'. Items are added from left to right.
ICON is the base name of a file containing the image to use. The
-function will first try to use ICON.xpm, then ICON.pbm, and finally
+function will first try to use lc-ICON.xpm if display-color-cells
+is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
ICON.xbm, using `find-image'."
(let* ((fg (face-attribute 'tool-bar :foreground))
(bg (face-attribute 'tool-bar :background))
(colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
(if (eq bg 'unspecified) nil (list :background bg))))
+ (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
+ (xpm-lo-spec (if (> (display-color-cells) 256)
+ nil
+ (list :type 'xpm :file (concat "lc-" icon ".xpm"))))
+ (pbm-spec (append (list :type 'pbm :file (concat icon ".pbm")) colors))
+ (xbm-spec (append (list :type 'xbm :file (concat icon ".xbm")) colors))
(image (find-image
(if (display-color-p)
- (list (list :type 'xpm :file (concat icon ".xpm"))
- (append (list :type 'pbm :file (concat icon ".pbm"))
- colors)
- (append (list :type 'xbm :file (concat icon ".xbm"))
- colors))
- (list (append (list :type 'pbm :file (concat icon ".pbm"))
- colors)
- (append (list :type 'xbm :file (concat icon ".xbm"))
- colors)
- (list :type 'xpm :file (concat icon ".xpm")))))))
+ (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
+ (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))))
+
(when (and (display-images-p) image)
(unless (image-mask-p image)
(setq image (append image '(:mask heuristic))))
@@ -170,17 +171,15 @@ MAP must contain appropriate binding for `[menu-bar]' which holds a keymap."
(bg (face-attribute 'tool-bar :background))
(colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
(if (eq bg 'unspecified) nil (list :background bg))))
+ (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
+ (xpm-lo-spec (if (> (display-color-cells) 256)
+ nil
+ (list :type 'xpm :file (concat "lc-" icon ".xpm"))))
+ (pbm-spec (append (list :type 'pbm :file (concat icon ".pbm")) colors))
+ (xbm-spec (append (list :type 'xbm :file (concat icon ".xbm")) colors))
(spec (if (display-color-p)
- (list (list :type 'xpm :file (concat icon ".xpm"))
- (append (list :type 'pbm :file (concat icon ".pbm"))
- colors)
- (append (list :type 'xbm :file (concat icon ".xbm"))
- colors))
- (list (append (list :type 'pbm :file (concat icon ".pbm"))
- colors)
- (append (list :type 'xbm :file (concat icon ".xbm"))
- colors)
- (list :type 'xpm :file (concat icon ".xpm")))))
+ (list xpm-lo-spec xpm-spec pbm-spec xbm-spec)
+ (list pbm-spec xbm-spec xpm-lo-spec xpm-spec)))
(image (find-image spec))
submap key)
(when (and (display-images-p) image)
@@ -239,11 +238,14 @@ MAP must contain appropriate binding for `[menu-bar]' which holds a keymap."
(tool-bar-add-item-from-menu 'undo "undo" nil
:visible '(not (eq 'special (get major-mode
'mode-class))))
- (tool-bar-add-item-from-menu 'kill-region "cut" nil
+ (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
+ "cut" nil
:visible '(not (eq 'special (get major-mode
'mode-class))))
- (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy")
- (tool-bar-add-item-from-menu 'yank "paste" nil
+ (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
+ "copy")
+ (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
+ "paste" nil
:visible '(not (eq 'special (get major-mode
'mode-class))))
(tool-bar-add-item-from-menu 'nonincremental-search-forward "search")
diff --git a/lisp/toolbar/undo.pbm b/lisp/toolbar/undo.pbm
index 5bed67caa40..7f9b8975d2f 100644
--- a/lisp/toolbar/undo.pbm
+++ b/lisp/toolbar/undo.pbm
Binary files differ
diff --git a/lisp/toolbar/undo.xpm b/lisp/toolbar/undo.xpm
index c48b0fdae6f..ca5bd760937 100644
--- a/lisp/toolbar/undo.xpm
+++ b/lisp/toolbar/undo.xpm
@@ -1,35 +1,58 @@
/* XPM */
-static char *magick[] = {
-/* columns rows colors chars-per-pixel */
-"24 24 5 1",
-" c Gray0",
-". c #ae6e66e76a0a",
-"X c #c6c67d7d8181",
-"o c #e4e4e4e4dcdc",
-"O c None",
-/* pixels */
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOO OOOOOOOOOOOOOO",
-"OOOOOOOO OOOOOOOOOOOOOO",
-"OOOOOOO oX OOOOOOOOOOO",
-"OOOOOO ooooX. OOOOOOOOO",
-"OOOOOOO oo .. OOOOOOOO",
-"OOOOOOOO OOO . OOOOOOOO",
-"OOOOOOOOO OOOO . OOOOOOO",
-"OOOOOOOOOOOOOOO OOOOOOO",
-"OOOOOOOOOOOOOOO OOOOOOO",
-"OOOOOOOOOOOOOOO OOOOOOOO",
-"OOOOOOOOOOOOOO OOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO",
-"OOOOOOOOOOOOOOOOOOOOOOOO"
-};
+static char * undo_xpm[] = {
+"24 24 31 1",
+" c None",
+". c #000000",
+"+ c #EFE5BA",
+"@ c #EFE7C1",
+"# c #EED680",
+"$ c #EFE4B6",
+"% c #D5B75D",
+"& c #B29544",
+"* c #D1B051",
+"= c #C0AF73",
+"- c #C0A048",
+"; c #986B07",
+"> c #D1940C",
+", c #E0B74C",
+"' c #D9C374",
+") c #8F6406",
+"! c #D59D1C",
+"~ c #B1933F",
+"{ c #DFB74A",
+"] c #CCB76D",
+"^ c #B8820A",
+"/ c #D9A72E",
+"( c #D7A62C",
+"_ c #C7B26A",
+": c #D4B150",
+"< c #A39256",
+"[ c #E2CB79",
+"} c #C9B46B",
+"| c #8D7E4A",
+"1 c #AE9C5C",
+"2 c #96864F",
+" ",
+" ",
+" ",
+" . ",
+" .. ",
+" .+. ",
+" .@#.... ",
+" .$####%&. ",
+" .+#######*. ",
+" .=#########-. ",
+" .;>>>>>>,#'.. ",
+" .)>>>>>>!#~. ",
+" .)>...;>{]. ",
+" .;. ..^/#. ",
+" .. ..>#. ",
+" . .(_. ",
+" .:<. ",
+" .[. ",
+" .}|. ",
+" .12. ",
+" .. ",
+" ",
+" ",
+" "};
diff --git a/lisp/toolbar/up_arrow.pbm b/lisp/toolbar/up_arrow.pbm
index ca7e04f7a50..7c792bef796 100644
--- a/lisp/toolbar/up_arrow.pbm
+++ b/lisp/toolbar/up_arrow.pbm
Binary files differ
diff --git a/lisp/toolbar/up_arrow.xpm b/lisp/toolbar/up_arrow.xpm
index 44243cfe7f6..09963557d1b 100644
--- a/lisp/toolbar/up_arrow.xpm
+++ b/lisp/toolbar/up_arrow.xpm
@@ -1,33 +1,91 @@
/* XPM */
static char * up_arrow_xpm[] = {
-"24 24 9 1",
+"24 24 67 1",
" c None",
-". c #020202",
-"+ c #121A12",
-"@ c #78A16E",
-"# c #86AD7D",
-"$ c #B2C6AE",
-"% c #263222",
-"& c #E7EDE6",
-"* c #497241",
+". c #000000",
+"+ c #2F2F2F",
+"@ c #A5B4A4",
+"# c #E8F4E6",
+"$ c #96B892",
+"% c #41533C",
+"& c #F1FFF0",
+"* c #B8D6B7",
+"= c #9FC49D",
+"- c #66815E",
+"; c #B6D4B5",
+"> c #B9D7B8",
+", c #A1C69F",
+"' c #68835F",
+") c #637D5B",
+"! c #3F5239",
+"~ c #B8D7B7",
+"{ c #A2C7A0",
+"] c #6A8561",
+"^ c #657F5C",
+"/ c #617959",
+"( c #3E4F39",
+"_ c #F0FEEF",
+": c #B7D5B6",
+"< c #657E5C",
+"[ c #5D7555",
+"} c #D6EAD6",
+"| c #BFD4BF",
+"1 c #C0D5C0",
+"2 c #637C5B",
+"3 c #4D6246",
+"4 c #4C6046",
+"5 c #C7E1C6",
+"6 c #A1C69E",
+"7 c #67815E",
+"8 c #627B59",
+"9 c #3D4E39",
+"0 c #D0E7D0",
+"a c #B5D3B4",
+"b c #A0C39D",
+"c c #607958",
+"d c #B5D2B4",
+"e c #9DC19B",
+"f c #647D5B",
+"g c #607858",
+"h c #C6E0C5",
+"i c #B4D2B3",
+"j c #9CBF99",
+"k c #C5DFC4",
+"l c #B1CEB0",
+"m c #99BC97",
+"n c #617A59",
+"o c #5E7756",
+"p c #C0D9BF",
+"q c #AFCCAE",
+"r c #AECBAD",
+"s c #93B690",
+"t c #607857",
+"u c #5E7656",
+"v c #8DB389",
+"w c #748A72",
+"x c #71916E",
+"y c #5A7257",
+"z c #4D6247",
+"A c #4D6146",
+"B c #43543D",
" ",
" ",
-" ",
-" ",
-" .. ",
-" .. ",
-" .$*. ",
-" +&*. ",
-" .&&@*. ",
-" .&&@*. ",
-" .&&&@@*. ",
-" .&&&##*. ",
-" .&&&&#@@*. ",
-" .&&&&###*. ",
-" .&&&&&##@@*. ",
-" .&&&&&###@@. ",
-" .$$$$$$@@@@**. ",
-" ......%....... ",
+" . ",
+" +@. ",
+" .#$%. ",
+" .&*=-%. ",
+" .&;>,')!. ",
+" .&~;>{]^/(. ",
+" ._~>:>,]</[(. ",
+" .}|1>~~,'23444. ",
+" .....5;;6789..... ",
+" .0;ab^c9. ",
+" .5;defg9. ",
+" .haij2g9. ",
+" .kilmno9. ",
+" .pqrstu9. ",
+" .vwxyzAB. ",
+" ......... ",
" ",
" ",
" ",
diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el
new file mode 100644
index 00000000000..54323e41dd3
--- /dev/null
+++ b/lisp/tree-widget.el
@@ -0,0 +1,736 @@
+;;; tree-widget.el --- Tree widget
+
+;; Copyright (C) 2004 Free Software Foundation, Inc.
+
+;; Author: David Ponce <david@dponce.com>
+;; Maintainer: David Ponce <david@dponce.com>
+;; Created: 16 Feb 2001
+;; Keywords: extensions
+
+;; 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 2, 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 this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;;
+;; This library provide a tree widget useful to display data
+;; structures organized in a hierarchical order.
+;;
+;; The following properties are specific to the tree widget:
+;;
+;; :open
+;; Set to non-nil to unfold the tree. By default the tree is
+;; folded.
+;;
+;; :node
+;; Specify the widget used to represent a tree node. By default
+;; this is an `item' widget which displays the tree-widget :tag
+;; property value if defined or a string representation of the
+;; tree-widget value.
+;;
+;; :keep
+;; Specify a list of properties to keep when the tree is
+;; folded so they can be recovered when the tree is unfolded.
+;; This property can be used in child widgets too.
+;;
+;; :dynargs
+;; Specify a function to be called when the tree is unfolded, to
+;; dynamically provide the tree children in response to an unfold
+;; request. This function will be passed the tree widget and
+;; must return a list of child widgets. That list will be stored
+;; as the :args property of the parent tree.
+
+;; To speed up successive unfold requests, the :dynargs function
+;; can directly return the :args value if non-nil. Refreshing
+;; child values can be achieved by giving the :args property the
+;; value nil, then redrawing the tree.
+;;
+;; :has-children
+;; Specify if this tree has children. This property has meaning
+;; only when used with the above :dynargs one. It indicates that
+;; child widgets exist but will be dynamically provided when
+;; unfolding the node.
+;;
+;; :open-control (default `tree-widget-open-control')
+;; :close-control (default `tree-widget-close-control')
+;; :empty-control (default `tree-widget-empty-control')
+;; :leaf-control (default `tree-widget-leaf-control')
+;; :guide (default `tree-widget-guide')
+;; :end-guide (default `tree-widget-end-guide')
+;; :no-guide (default `tree-widget-no-guide')
+;; :handle (default `tree-widget-handle')
+;; :no-handle (default `tree-widget-no-handle')
+;;
+;; The above nine properties define the widgets used to draw the tree.
+;; For example, using widgets that display this values:
+;;
+;; open-control "[-] "
+;; close-control "[+] "
+;; empty-control "[X] "
+;; leaf-control "[>] "
+;; guide " |"
+;; noguide " "
+;; end-guide " `"
+;; handle "-"
+;; no-handle " "
+;;
+;; A tree will look like this:
+;;
+;; [-] 1 open-control
+;; |-[+] 1.0 guide+handle+close-control
+;; |-[X] 1.1 guide+handle+empty-control
+;; `-[-] 1.2 end-guide+handle+open-control
+;; |-[>] 1.2.1 no-guide+no-handle+guide+handle+leaf-control
+;; `-[>] 1.2.2 no-guide+no-handle+end-guide+handle+leaf-control
+;;
+;; By default, the tree widget try to use images instead of strings to
+;; draw a nice-looking tree. See the `tree-widget-themes-directory'
+;; and `tree-widget-theme' options for more details.
+;;
+
+;;; History:
+;;
+
+;;; Code:
+(eval-when-compile (require 'cl))
+(require 'wid-edit)
+
+;;; Customization
+;;
+(defgroup tree-widget nil
+ "Customization support for the Tree Widget Library."
+ :version "21.4"
+ :group 'widgets)
+
+(defcustom tree-widget-image-enable
+ (not (or (featurep 'xemacs) (< emacs-major-version 21)))
+ "*non-nil means that tree-widget will try to use images."
+ :type 'boolean
+ :group 'tree-widget)
+
+(defcustom tree-widget-themes-directory "tree-widget"
+ "*Name of the directory where to lookup for image themes.
+When nil use the directory where the tree-widget library is located.
+When a relative name is specified, try to locate that sub-directory in
+`load-path', then in the data directory, and use the first one found.
+Default is to search for a \"tree-widget\" sub-directory.
+
+The data directory is the value of:
+ - the variable `data-directory' on GNU Emacs;
+ - `(locate-data-directory \"tree-widget\")' on XEmacs."
+ :type '(choice (const :tag "Default" "tree-widget")
+ (const :tag "With the library" nil)
+ (directory :format "%{%t%}:\n%v"))
+ :group 'tree-widget)
+
+(defcustom tree-widget-theme nil
+ "*Name of the theme to use to lookup for images.
+The theme name must be a subdirectory in `tree-widget-themes-directory'.
+If nil use the \"default\" theme.
+When a image is not found in the current theme, the \"default\" theme
+is searched too.
+A complete theme should contain images with these file names:
+
+Name Represents
+----------- ------------------------------------------------
+open opened node (for example an open folder)
+close closed node (for example a close folder)
+empty empty node (a node without children)
+leaf leaf node (for example a document)
+guide a vertical guide line
+no-guide an invisible guide line
+end-guide the end of a vertical guide line
+handle an horizontal line drawn before a node control
+no-handle an invisible handle
+----------- ------------------------------------------------"
+ :type '(choice (const :tag "Default" nil)
+ (string :tag "Name"))
+ :group 'tree-widget)
+
+(defcustom tree-widget-image-properties-emacs
+ '(:ascent center :mask (heuristic t))
+ "*Properties of GNU Emacs images."
+ :type 'plist
+ :group 'tree-widget)
+
+(defcustom tree-widget-image-properties-xemacs
+ nil
+ "*Properties of XEmacs images."
+ :type 'plist
+ :group 'tree-widget)
+
+;;; Image support
+;;
+(eval-when-compile ;; GNU Emacs/XEmacs compatibility stuff
+ (cond
+ ;; XEmacs
+ ((featurep 'xemacs)
+ (defsubst tree-widget-use-image-p ()
+ "Return non-nil if image support is currently enabled."
+ (and tree-widget-image-enable
+ widget-glyph-enable
+ (console-on-window-system-p)))
+ (defsubst tree-widget-create-image (type file &optional props)
+ "Create an image of type TYPE from FILE.
+Give the image the specified properties PROPS.
+Return the new image."
+ (apply 'make-glyph `([,type :file ,file ,@props])))
+ (defsubst tree-widget-image-formats ()
+ "Return the list of image formats, file name suffixes associations.
+See also the option `widget-image-file-name-suffixes'."
+ (delq nil
+ (mapcar
+ #'(lambda (fmt)
+ (and (valid-image-instantiator-format-p (car fmt)) fmt))
+ widget-image-file-name-suffixes)))
+ )
+ ;; GNU Emacs
+ (t
+ (defsubst tree-widget-use-image-p ()
+ "Return non-nil if image support is currently enabled."
+ (and tree-widget-image-enable
+ widget-image-enable
+ (display-images-p)))
+ (defsubst tree-widget-create-image (type file &optional props)
+ "Create an image of type TYPE from FILE.
+Give the image the specified properties PROPS.
+Return the new image."
+ (apply 'create-image `(,file ,type nil ,@props)))
+ (defsubst tree-widget-image-formats ()
+ "Return the list of image formats, file name suffixes associations.
+See also the option `widget-image-conversion'."
+ (delq nil
+ (mapcar
+ #'(lambda (fmt)
+ (and (image-type-available-p (car fmt)) fmt))
+ widget-image-conversion)))
+ ))
+ )
+
+;; Buffer local cache of theme data.
+(defvar tree-widget--theme nil)
+
+(defsubst tree-widget-theme-name ()
+ "Return the current theme name, or nil if no theme is active."
+ (and tree-widget--theme (aref tree-widget--theme 0)))
+
+(defsubst tree-widget-set-theme (&optional name)
+ "In the current buffer, set the theme to use for images.
+The current buffer should be where the tree widget is drawn.
+Optional argument NAME is the name of the theme to use, which defaults
+to the value of the variable `tree-widget-theme'.
+Does nothing if NAME is the name of the current theme."
+ (or name (setq name (or tree-widget-theme "default")))
+ (unless (equal name (tree-widget-theme-name))
+ (set (make-local-variable 'tree-widget--theme)
+ (make-vector 4 nil))
+ (aset tree-widget--theme 0 name)))
+
+(defun tree-widget-themes-directory ()
+ "Locate the directory where to search for a theme.
+It is defined in variable `tree-widget-themes-directory'.
+Return the absolute name of the directory found, or nil if the
+specified directory is not accessible."
+ (let ((found (aref tree-widget--theme 1)))
+ (if found
+ ;; The directory is available in the cache.
+ (unless (eq found 'void) found)
+ (cond
+ ;; Use the directory where tree-widget is located.
+ ((null tree-widget-themes-directory)
+ (setq found (locate-library "tree-widget"))
+ (when found
+ (setq found (file-name-directory found))
+ (or (file-accessible-directory-p found)
+ (setq found nil))))
+ ;; Check accessibility of absolute directory name.
+ ((file-name-absolute-p tree-widget-themes-directory)
+ (setq found (expand-file-name tree-widget-themes-directory))
+ (or (file-accessible-directory-p found)
+ (setq found nil)))
+ ;; Locate a sub-directory in `load-path' and data directory.
+ (t
+ (let ((path
+ (append load-path
+ ;; The data directory depends on which, GNU
+ ;; Emacs or XEmacs, is running.
+ (list (if (fboundp 'locate-data-directory)
+ (locate-data-directory "tree-widget")
+ data-directory)))))
+ (while (and path (not found))
+ (when (car path)
+ (setq found (expand-file-name
+ tree-widget-themes-directory (car path)))
+ (or (file-accessible-directory-p found)
+ (setq found nil)))
+ (setq path (cdr path))))))
+ ;; Store the result in the cache for later use.
+ (aset tree-widget--theme 1 (or found 'void))
+ found)))
+
+(defsubst tree-widget-set-image-properties (props)
+ "In current theme, set images properties to PROPS."
+ (aset tree-widget--theme 2 props))
+
+(defun tree-widget-image-properties (file)
+ "Return properties of images in current theme.
+If the \"tree-widget-theme-setup.el\" file exists in the directory
+where is located the image FILE, load it to setup theme images
+properties. Typically that file should contain something like this:
+
+ (tree-widget-set-image-properties
+ (if (featurep 'xemacs)
+ '(:ascent center)
+ '(:ascent center :mask (heuristic t))
+ ))
+
+By default, use the global properties provided in variables
+`tree-widget-image-properties-emacs' or
+`tree-widget-image-properties-xemacs'."
+ ;; If properties are in the cache, use them.
+ (or (aref tree-widget--theme 2)
+ (progn
+ ;; Load tree-widget-theme-setup if available.
+ (load (expand-file-name
+ "tree-widget-theme-setup"
+ (file-name-directory file)) t t)
+ ;; If properties have been setup, use them.
+ (or (aref tree-widget--theme 2)
+ ;; By default, use supplied global properties.
+ (tree-widget-set-image-properties
+ (if (featurep 'xemacs)
+ tree-widget-image-properties-xemacs
+ tree-widget-image-properties-emacs))))))
+
+(defun tree-widget-find-image (name)
+ "Find the image with NAME in current theme.
+NAME is an image file name sans extension.
+Search first in current theme, then in default theme.
+A theme is a sub-directory of the root theme directory specified in
+variable `tree-widget-themes-directory'.
+Return the first image found having a supported format in those
+returned by the function `tree-widget-image-formats', or nil if not
+found."
+ (when (tree-widget-use-image-p)
+ ;; Ensure there is an active theme.
+ (tree-widget-set-theme (tree-widget-theme-name))
+ ;; If the image is in the cache, return it.
+ (or (cdr (assoc name (aref tree-widget--theme 3)))
+ ;; Search the image in the current, then default themes.
+ (let ((default-directory (tree-widget-themes-directory)))
+ (when default-directory
+ (let* ((theme (tree-widget-theme-name))
+ (path (mapcar 'expand-file-name
+ (if (equal theme "default")
+ '("default")
+ (list theme "default"))))
+ (formats (tree-widget-image-formats))
+ (found
+ (catch 'found
+ (dolist (dir path)
+ (dolist (fmt formats)
+ (dolist (ext (cdr fmt))
+ (let ((file (expand-file-name
+ (concat name ext) dir)))
+ (and (file-readable-p file)
+ (file-regular-p file)
+ (throw 'found
+ (cons (car fmt) file)))))))
+ nil)))
+ (when found
+ (let ((image
+ (tree-widget-create-image
+ (car found) (cdr found)
+ (tree-widget-image-properties (cdr found)))))
+ ;; Store image in the cache for later use.
+ (push (cons name image) (aref tree-widget--theme 3))
+ image))))))))
+
+;;; Widgets
+;;
+(defvar tree-widget-button-keymap
+ (let (parent-keymap mouse-button1 keymap)
+ (if (featurep 'xemacs)
+ (setq parent-keymap widget-button-keymap
+ mouse-button1 [button1])
+ (setq parent-keymap widget-keymap
+ mouse-button1 [down-mouse-1]))
+ (setq keymap (copy-keymap parent-keymap))
+ (define-key keymap mouse-button1 'widget-button-click)
+ keymap)
+ "Keymap used inside node handle buttons.")
+
+(define-widget 'tree-widget-control 'push-button
+ "Base `tree-widget' control."
+ :format "%[%t%]"
+ :button-keymap tree-widget-button-keymap ; XEmacs
+ :keymap tree-widget-button-keymap ; Emacs
+ )
+
+(define-widget 'tree-widget-open-control 'tree-widget-control
+ "Control widget that represents a opened `tree-widget' node."
+ :tag "[-] "
+ ;;:tag-glyph (tree-widget-find-image "open")
+ :notify 'tree-widget-close-node
+ :help-echo "Hide node"
+ )
+
+(define-widget 'tree-widget-empty-control 'tree-widget-open-control
+ "Control widget that represents an empty opened `tree-widget' node."
+ :tag "[X] "
+ ;;:tag-glyph (tree-widget-find-image "empty")
+ )
+
+(define-widget 'tree-widget-close-control 'tree-widget-control
+ "Control widget that represents a closed `tree-widget' node."
+ :tag "[+] "
+ ;;:tag-glyph (tree-widget-find-image "close")
+ :notify 'tree-widget-open-node
+ :help-echo "Show node"
+ )
+
+(define-widget 'tree-widget-leaf-control 'item
+ "Control widget that represents a leaf node."
+ :tag " " ;; Need at least a char to display the image :-(
+ ;;:tag-glyph (tree-widget-find-image "leaf")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget-guide 'item
+ "Widget that represents a guide line."
+ :tag " |"
+ ;;:tag-glyph (tree-widget-find-image "guide")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget-end-guide 'item
+ "Widget that represents the end of a guide line."
+ :tag " `"
+ ;;:tag-glyph (tree-widget-find-image "end-guide")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget-no-guide 'item
+ "Widget that represents an invisible guide line."
+ :tag " "
+ ;;:tag-glyph (tree-widget-find-image "no-guide")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget-handle 'item
+ "Widget that represent a node handle."
+ :tag " "
+ ;;:tag-glyph (tree-widget-find-image "handle")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget-no-handle 'item
+ "Widget that represent an invisible node handle."
+ :tag " "
+ ;;:tag-glyph (tree-widget-find-image "no-handle")
+ :format "%t"
+ )
+
+(define-widget 'tree-widget 'default
+ "Tree widget."
+ :format "%v"
+ :convert-widget 'widget-types-convert-widget
+ :value-get 'widget-value-value-get
+ :value-create 'tree-widget-value-create
+ :value-delete 'tree-widget-value-delete
+ )
+
+;;; Widget support functions
+;;
+(defun tree-widget-p (widget)
+ "Return non-nil if WIDGET is a `tree-widget' widget."
+ (let ((type (widget-type widget)))
+ (while (and type (not (eq type 'tree-widget)))
+ (setq type (widget-type (get type 'widget-type))))
+ (eq type 'tree-widget)))
+
+(defsubst tree-widget-get-super (widget property)
+ "Return WIDGET's inherited PROPERTY value."
+ (widget-get (get (widget-type (get (widget-type widget)
+ 'widget-type))
+ 'widget-type)
+ property))
+
+(defsubst tree-widget-super-format-handler (widget escape)
+ "Call WIDGET's inherited format handler to process ESCAPE character."
+ (let ((handler (tree-widget-get-super widget :format-handler)))
+ (and handler (funcall handler widget escape))))
+
+(defun tree-widget-format-handler (widget escape)
+ "For WIDGET, signal that the %p format template is obsolete.
+Call WIDGET's inherited format handler to process other ESCAPE
+characters."
+ (if (eq escape ?p)
+ (message "The %%p format template is obsolete and ignored")
+ (tree-widget-super-format-handler widget escape)))
+(make-obsolete 'tree-widget-format-handler
+ 'tree-widget-super-format-handler)
+
+(defsubst tree-widget-node (widget)
+ "Return the tree WIDGET :node value.
+If not found setup a default 'item' widget."
+ (let ((node (widget-get widget :node)))
+ (unless node
+ (setq node `(item :tag ,(or (widget-get widget :tag)
+ (widget-princ-to-string
+ (widget-value widget)))))
+ (widget-put widget :node node))
+ node))
+
+(defsubst tree-widget-open-control (widget)
+ "Return the opened node control specified in WIDGET."
+ (or (widget-get widget :open-control)
+ 'tree-widget-open-control))
+
+(defsubst tree-widget-close-control (widget)
+ "Return the closed node control specified in WIDGET."
+ (or (widget-get widget :close-control)
+ 'tree-widget-close-control))
+
+(defsubst tree-widget-empty-control (widget)
+ "Return the empty node control specified in WIDGET."
+ (or (widget-get widget :empty-control)
+ 'tree-widget-empty-control))
+
+(defsubst tree-widget-leaf-control (widget)
+ "Return the leaf node control specified in WIDGET."
+ (or (widget-get widget :leaf-control)
+ 'tree-widget-leaf-control))
+
+(defsubst tree-widget-guide (widget)
+ "Return the guide line widget specified in WIDGET."
+ (or (widget-get widget :guide)
+ 'tree-widget-guide))
+
+(defsubst tree-widget-end-guide (widget)
+ "Return the end of guide line widget specified in WIDGET."
+ (or (widget-get widget :end-guide)
+ 'tree-widget-end-guide))
+
+(defsubst tree-widget-no-guide (widget)
+ "Return the invisible guide line widget specified in WIDGET."
+ (or (widget-get widget :no-guide)
+ 'tree-widget-no-guide))
+
+(defsubst tree-widget-handle (widget)
+ "Return the node handle line widget specified in WIDGET."
+ (or (widget-get widget :handle)
+ 'tree-widget-handle))
+
+(defsubst tree-widget-no-handle (widget)
+ "Return the node invisible handle line widget specified in WIDGET."
+ (or (widget-get widget :no-handle)
+ 'tree-widget-no-handle))
+
+(defun tree-widget-keep (arg widget)
+ "Save in ARG the WIDGET properties specified by :keep."
+ (dolist (prop (widget-get widget :keep))
+ (widget-put arg prop (widget-get widget prop))))
+
+(defun tree-widget-children-value-save (widget &optional args node)
+ "Save WIDGET children values.
+Children properties and values are saved in ARGS if non-nil else in
+WIDGET :args property value. Data node properties and value are saved
+in NODE if non-nil else in WIDGET :node property value."
+ (let ((args (or args (widget-get widget :args)))
+ (node (or node (tree-widget-node widget)))
+ (children (widget-get widget :children))
+ (node-child (widget-get widget :tree-widget--node))
+ arg child)
+ (while (and args children)
+ (setq arg (car args)
+ args (cdr args)
+ child (car children)
+ children (cdr children))
+ (if (tree-widget-p child)
+;;;; The child is a tree node.
+ (progn
+ ;; Backtrack :args and :node properties.
+ (widget-put arg :args (widget-get child :args))
+ (widget-put arg :node (tree-widget-node child))
+ ;; Save :open property.
+ (widget-put arg :open (widget-get child :open))
+ ;; The node is open.
+ (when (widget-get child :open)
+ ;; Save the widget value.
+ (widget-put arg :value (widget-value child))
+ ;; Save properties specified in :keep.
+ (tree-widget-keep arg child)
+ ;; Save children.
+ (tree-widget-children-value-save
+ child (widget-get arg :args) (widget-get arg :node))))
+;;;; Another non tree node.
+ ;; Save the widget value
+ (widget-put arg :value (widget-value child))
+ ;; Save properties specified in :keep.
+ (tree-widget-keep arg child)))
+ (when (and node node-child)
+ ;; Assume that the node child widget is not a tree!
+ ;; Save the node child widget value.
+ (widget-put node :value (widget-value node-child))
+ ;; Save the node child properties specified in :keep.
+ (tree-widget-keep node node-child))
+ ))
+
+(defvar tree-widget-after-toggle-functions nil
+ "Hooks run after toggling a `tree-widget' folding.
+Each function will receive the `tree-widget' as its unique argument.
+This variable should be local to each buffer used to display
+widgets.")
+
+(defun tree-widget-close-node (widget &rest ignore)
+ "Close the `tree-widget' node associated to this control WIDGET.
+WIDGET's parent should be a `tree-widget'.
+IGNORE other arguments."
+ (let ((tree (widget-get widget :parent)))
+ ;; Before folding the node up, save children values so next open
+ ;; can recover them.
+ (tree-widget-children-value-save tree)
+ (widget-put tree :open nil)
+ (widget-value-set tree nil)
+ (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
+
+(defun tree-widget-open-node (widget &rest ignore)
+ "Open the `tree-widget' node associated to this control WIDGET.
+WIDGET's parent should be a `tree-widget'.
+IGNORE other arguments."
+ (let ((tree (widget-get widget :parent)))
+ (widget-put tree :open t)
+ (widget-value-set tree t)
+ (run-hook-with-args 'tree-widget-after-toggle-functions tree)))
+
+(defun tree-widget-value-delete (widget)
+ "Delete tree WIDGET children."
+ ;; Delete children
+ (widget-children-value-delete widget)
+ ;; Delete node child
+ (widget-delete (widget-get widget :tree-widget--node))
+ (widget-put widget :tree-widget--node nil))
+
+(defun tree-widget-value-create (tree)
+ "Create the TREE widget."
+ (let* ((widget-image-enable (tree-widget-use-image-p)) ; Emacs
+ (widget-glyph-enable widget-image-enable) ; XEmacs
+ (node (tree-widget-node tree))
+ children buttons)
+ (if (widget-get tree :open)
+;;;; Unfolded node.
+ (let* ((args (widget-get tree :args))
+ (dynargs (widget-get tree :dynargs))
+ (flags (widget-get tree :tree-widget--guide-flags))
+ (rflags (reverse flags))
+ (guide (tree-widget-guide tree))
+ (noguide (tree-widget-no-guide tree))
+ (endguide (tree-widget-end-guide tree))
+ (handle (tree-widget-handle tree))
+ (nohandle (tree-widget-no-handle tree))
+ ;; Lookup for images and set widgets' tag-glyphs here,
+ ;; to allow to dynamically change the image theme.
+ (guidi (tree-widget-find-image "guide"))
+ (noguidi (tree-widget-find-image "no-guide"))
+ (endguidi (tree-widget-find-image "end-guide"))
+ (handli (tree-widget-find-image "handle"))
+ (nohandli (tree-widget-find-image "no-handle"))
+ child)
+ (when dynargs
+ ;; Request the definition of dynamic children
+ (setq dynargs (funcall dynargs tree))
+ ;; Unless children have changed, reuse the widgets
+ (unless (eq args dynargs)
+ (setq args (mapcar 'widget-convert dynargs))
+ (widget-put tree :args args)))
+ ;; Insert the node control
+ (push (widget-create-child-and-convert
+ tree (if args (tree-widget-open-control tree)
+ (tree-widget-empty-control tree))
+ :tag-glyph (tree-widget-find-image
+ (if args "open" "empty")))
+ buttons)
+ ;; Insert the node element
+ (widget-put tree :tree-widget--node
+ (widget-create-child-and-convert tree node))
+ ;; Insert children
+ (while args
+ (setq child (car args)
+ args (cdr args))
+ ;; Insert guide lines elements
+ (dolist (f rflags)
+ (widget-create-child-and-convert
+ tree (if f guide noguide)
+ :tag-glyph (if f guidi noguidi))
+ (widget-create-child-and-convert
+ tree nohandle :tag-glyph nohandli)
+ )
+ (widget-create-child-and-convert
+ tree (if args guide endguide)
+ :tag-glyph (if args guidi endguidi))
+ ;; Insert the node handle line
+ (widget-create-child-and-convert
+ tree handle :tag-glyph handli)
+ ;; If leaf node, insert a leaf node control
+ (unless (tree-widget-p child)
+ (push (widget-create-child-and-convert
+ tree (tree-widget-leaf-control tree)
+ :tag-glyph (tree-widget-find-image "leaf"))
+ buttons))
+ ;; Insert the child element
+ (push (widget-create-child-and-convert
+ tree child
+ :tree-widget--guide-flags (cons (if args t) flags))
+ children)))
+;;;; Folded node.
+ ;; Insert the closed node control
+ (push (widget-create-child-and-convert
+ tree (tree-widget-close-control tree)
+ :tag-glyph (tree-widget-find-image "close"))
+ buttons)
+ ;; Insert the node element
+ (widget-put tree :tree-widget--node
+ (widget-create-child-and-convert tree node)))
+ ;; Save widget children and buttons
+ (widget-put tree :children (nreverse children))
+ (widget-put tree :buttons buttons)
+ ))
+
+;;; Utilities
+;;
+(defun tree-widget-map (widget fun)
+ "For each WIDGET displayed child call function FUN.
+FUN is called with three arguments like this:
+
+ (FUN CHILD IS-NODE WIDGET)
+
+where:
+- - CHILD is the child widget.
+- - IS-NODE is non-nil if CHILD is WIDGET node widget."
+ (when (widget-get widget :tree-widget--node)
+ (funcall fun (widget-get widget :tree-widget--node) t widget)
+ (dolist (child (widget-get widget :children))
+ (if (tree-widget-p child)
+ ;; The child is a tree node.
+ (tree-widget-map child fun)
+ ;; Another non tree node.
+ (funcall fun child nil widget)))))
+
+(provide 'tree-widget)
+
+;;; arch-tag: c3a1ada2-1663-41dc-9d16-2479ed8320e8
+;;; tree-widget.el ends here
diff --git a/lisp/type-break.el b/lisp/type-break.el
index 26ac7f87ecb..253e1406f06 100644
--- a/lisp/type-break.el
+++ b/lisp/type-break.el
@@ -30,10 +30,10 @@
;; The docstring for the function `type-break-mode' summarizes most of the
;; details of the interface.
-;; This package relies on the assumption that you live entirely in emacs,
+;; This package relies on the assumption that you live entirely in Emacs,
;; as the author does. If that's not the case for you (e.g. you often
-;; suspend emacs or work in other windows) then this won't help very much;
-;; it will depend on just how often you switch back to emacs. At the very
+;; suspend Emacs or work in other windows) then this won't help very much;
+;; it will depend on just how often you switch back to Emacs. At the very
;; least, you will want to turn off the keystroke thresholds and rest
;; interval tracking.
@@ -95,7 +95,7 @@ use either \\[customize] or the function `type-break-mode'."
(defcustom type-break-good-rest-interval (/ type-break-interval 6)
"*Number of seconds of idle time considered to be an adequate typing rest.
-When this variable is non-nil, emacs checks the idle time between
+When this variable is non-nil, Emacs checks the idle time between
keystrokes. If this idle time is long enough to be considered a \"good\"
rest from typing, then the next typing break is simply rescheduled for later.
@@ -105,6 +105,17 @@ asked whether or not really to interrupt the break."
:group 'type-break)
;;;###autoload
+(defcustom type-break-good-break-interval nil
+ "*Number of seconds considered to be an adequate explicit typing rest.
+
+When this variable is non-nil, its value is considered to be a \"good\"
+length (in seconds) for a break initiated by the command `type-break',
+overriding `type-break-good-rest-interval'. This provides querying of
+break interruptions when `type-break-good-rest-interval' is nil."
+ :type 'integer
+ :group 'type-break)
+
+;;;###autoload
(defcustom type-break-keystroke-threshold
;; Assuming typing speed is 35wpm (on the average, do you really
;; type more than that in a minute? I spend a lot of time reading mail
@@ -200,15 +211,30 @@ Format specifiers are as used by `format-time-string'."
'(type-break-demo-boring type-break-demo-life type-break-demo-hanoi)
"*List of functions to consider running as demos during typing breaks.
When a typing break begins, one of these functions is selected randomly
-to have emacs do something interesting.
+to have Emacs do something interesting.
Any function in this list should start a demo which ceases as soon as a
key is pressed."
:type '(repeat function)
:group 'type-break)
+(defcustom type-break-demo-boring-stats nil
+ "*Show word per minute and keystroke figures in the Boring demo."
+ :type 'boolean
+ :group 'type-break)
+
+(defcustom type-break-terse-messages nil
+ "*Use slightly terser messages."
+ :type 'boolean
+ :group 'type-break)
+
+(defcustom type-break-file-name (convert-standard-filename "~/.type-break")
+ "*Name of file used to save state across sessions."
+ :type 'file
+ :group 'type-break)
+
(defvar type-break-post-command-hook '(type-break-check)
- "Hook run indirectly by post-command-hook for typing break functions.
+ "Hook run indirectly by `post-command-hook' for typing break functions.
This is not really intended to be set by the user, but it's probably
harmless to do so. Mainly it is used by various parts of the typing break
program to delay actions until after the user has completed some command.
@@ -257,7 +283,7 @@ See also `type-break-mode-line-format' and its members."
This variable, in conjunction with `type-break-warning-countdown-string-type'
\(which indicates whether this value is a number of keystrokes or seconds)
-is installed in mode-line-format to notify of imminent typing breaks.")
+is installed in `mode-line-format' to notify of imminent typing breaks.")
(defvar type-break-warning-countdown-string-type nil
"Indicates the unit type of `type-break-warning-countdown-string'.
@@ -275,6 +301,8 @@ It will be either \"seconds\" or \"keystrokes\".")
(defvar type-break-current-keystroke-warning-interval nil)
(defvar type-break-time-warning-count 0)
(defvar type-break-keystroke-warning-count 0)
+(defvar type-break-interval-start nil)
+
;;;###autoload
(defun type-break-mode (&optional prefix)
@@ -284,7 +312,7 @@ This is a minor mode, but it is global to all buffers by default.
When this mode is enabled, the user is encouraged to take typing breaks at
appropriate intervals; either after a specified amount of time or when the
user has exceeded a keystroke threshold. When the time arrives, the user
-is asked to take a break. If the user refuses at that time, emacs will ask
+is asked to take a break. If the user refuses at that time, Emacs will ask
again in a short period of time. The idea is to give the user enough time
to find a good breaking point in his or her work, but be sufficiently
annoying to discourage putting typing breaks off indefinitely.
@@ -309,9 +337,18 @@ affect the time schedule; it simply provides a default for the
If set, the variable `type-break-good-rest-interval' specifies the minimum
amount of time which is considered a reasonable typing break. Whenever
that time has elapsed, typing breaks are automatically rescheduled for
-later even if emacs didn't prompt you to take one first. Also, if a break
+later even if Emacs didn't prompt you to take one first. Also, if a break
is ended before this much time has elapsed, the user will be asked whether
-or not to continue.
+or not to continue. A nil value for this variable prevents automatic
+break rescheduling, making `type-break-interval' an upper bound on the time
+between breaks. In this case breaks will be prompted for as usual before
+the upper bound if the keystroke threshold is reached.
+
+If `type-break-good-rest-interval' is nil and
+`type-break-good-break-interval' is set, then confirmation is required to
+interrupt a break before `type-break-good-break-interval' seconds
+have passed. This provides for an upper bound on the time between breaks
+together with confirmation of interruptions to these breaks.
The variable `type-break-keystroke-threshold' is used to determine the
thresholds at which typing breaks should be considered. You can use
@@ -335,7 +372,12 @@ a typing break occur. They include:
`type-break-query-function'
`type-break-query-interval'
-Finally, the command `type-break-statistics' prints interesting things."
+The command `type-break-statistics' prints interesting things.
+
+Finally, a file (named `type-break-file-name') is used to store information
+across Emacs sessions. This provides recovery of the break status between
+sessions and after a crash. Manual changes to the file may result in
+problems."
(interactive "P")
(type-break-check-post-command-hook)
@@ -356,13 +398,52 @@ Finally, the command `type-break-statistics' prints interesting things."
minor-mode-alist)))
(type-break-keystroke-reset)
(type-break-mode-line-countdown-or-break nil)
- (type-break-schedule)
+
+ (if (boundp 'save-some-buffers-always)
+ (add-to-list 'save-some-buffers-always
+ (expand-file-name type-break-file-name)))
+
+ (setq type-break-time-last-break (type-break-get-previous-time))
+
+ ;; schedule according to break time from session file
+ (type-break-schedule
+ (let (diff)
+ (if (and type-break-time-last-break
+ (< (setq diff (type-break-time-difference
+ type-break-time-last-break
+ (current-time)))
+ type-break-interval))
+ ;; use the file's value
+ (progn
+ (setq type-break-keystroke-count
+ (type-break-get-previous-count))
+ ;; file the time, in case it was read from the auto-save file
+ (type-break-file-time type-break-interval-start)
+ (setq type-break-interval-start type-break-time-last-break)
+ (- type-break-interval diff))
+ ;; schedule from now
+ (setq type-break-interval-start (current-time))
+ (type-break-file-time type-break-interval-start)
+ type-break-interval))
+ type-break-interval-start
+ type-break-interval)
+
(and (interactive-p)
- (message "Type Break mode is enabled and reset")))
+ (message "Type Break mode is enabled and set")))
(t
(type-break-keystroke-reset)
(type-break-mode-line-countdown-or-break nil)
(type-break-cancel-schedule)
+ (do-auto-save)
+ (with-current-buffer (find-file-noselect type-break-file-name
+ 'nowarn)
+ (set-buffer-modified-p nil)
+ (unlock-buffer)
+ (kill-this-buffer))
+ (if (boundp 'save-some-buffers-always)
+ (setq save-some-buffers-always
+ (remove (expand-file-name type-break-file-name)
+ save-some-buffers-always)))
(and (interactive-p)
(message "Type Break mode is disabled")))))
type-break-mode)
@@ -370,7 +451,7 @@ Finally, the command `type-break-statistics' prints interesting things."
(defun type-break-mode-line-message-mode (&optional prefix)
"Enable or disable warnings in the mode line about typing breaks.
-A negative prefix argument disables this mode.
+A negative PREFIX argument disables this mode.
No argument or any non-negative argument enables it.
The user may also enable or disable this mode simply by setting the
@@ -398,7 +479,7 @@ When enabled, the user is periodically queried about whether to take a
typing break at that moment. The function which does this query is
specified by the variable `type-break-query-function'.
-A negative prefix argument disables this mode.
+A negative PREFIX argument disables this mode.
No argument or any non-negative argument enables it.
The user may also enable or disable this mode simply by setting the
@@ -413,6 +494,89 @@ variable of the same name."
type-break-query-mode)
+;;; session file functions
+
+(defvar type-break-auto-save-file-name
+ (let ((buffer-file-name type-break-file-name))
+ (make-auto-save-file-name))
+ "Auto-save name of `type-break-file-name'.")
+
+(defun type-break-file-time (&optional time)
+ "File break time in `type-break-file-name', unless the file is locked."
+ (if (not (stringp (file-locked-p type-break-file-name)))
+ (with-current-buffer (find-file-noselect type-break-file-name
+ 'nowarn)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert (format "%s\n\n" (or time type-break-interval-start)))
+ ;; file saving is left to auto-save
+ ))))
+
+(defun type-break-file-keystroke-count ()
+ "File keystroke count in `type-break-file-name', unless the file is locked."
+ (if (not (stringp (file-locked-p type-break-file-name)))
+ (with-current-buffer (find-file-noselect type-break-file-name
+ 'nowarn)
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (forward-line)
+ (delete-region (point) (save-excursion (end-of-line) (point)))
+ (insert (format "%s" type-break-keystroke-count))
+ ;; file saving is left to auto-save
+ )))))
+
+(defun timep (time)
+ "If TIME is in the format returned by `current-time' then
+return TIME, else return nil."
+ (and (listp time)
+ (eq (length time) 3)
+ (integerp (car time))
+ (integerp (nth 1 time))
+ (integerp (nth 2 time))
+ time))
+
+(defun type-break-choose-file ()
+ "Return file to read from."
+ (cond
+ ((and (file-exists-p type-break-auto-save-file-name)
+ (file-readable-p type-break-auto-save-file-name))
+ type-break-auto-save-file-name)
+ ((and (file-exists-p type-break-file-name)
+ (file-readable-p type-break-file-name))
+ type-break-file-name)
+ (t nil)))
+
+(defun type-break-get-previous-time ()
+ "Get previous break time from `type-break-file-name'.
+Returns nil if the file is missing or if the time breaks with the
+`current-time' format."
+ (let ((file (type-break-choose-file)))
+ (if file
+ (timep ;; returns expected format, else nil
+ (with-current-buffer (find-file-noselect file 'nowarn)
+ (save-excursion
+ (goto-char (point-min))
+ (read (current-buffer))))))))
+
+(defun type-break-get-previous-count ()
+ "Get previous keystroke count from `type-break-file-name'.
+Return 0 if the file is missing or if the form read is not an
+integer."
+ (let ((file (type-break-choose-file)))
+ (if (and file
+ (integerp
+ (setq file
+ (with-current-buffer
+ (find-file-noselect file 'nowarn)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line 1)
+ (read (current-buffer)))))))
+ file
+ 0)))
+
+
;;;###autoload
(defun type-break ()
"Take a typing break.
@@ -425,6 +589,8 @@ as per the function `type-break-schedule'."
(interactive)
(do-auto-save)
(type-break-cancel-schedule)
+ ;; remove any query scheduled during interactive invocation
+ (remove-hook 'type-break-post-command-hook 'type-break-do-query)
(let ((continue t)
(start-time (current-time)))
(setq type-break-time-last-break start-time)
@@ -435,7 +601,8 @@ as per the function `type-break-schedule'."
(other-window 1))
(delete-other-windows)
(scroll-right (window-width))
- (message "Press any key to resume from typing break.")
+ (unless type-break-terse-messages
+ (message "Press any key to resume from typing break."))
(random t)
(let* ((len (length type-break-demo-functions))
@@ -445,36 +612,45 @@ as per the function `type-break-schedule'."
(funcall fn)
(error nil))))
- (cond
- (type-break-good-rest-interval
- (let ((break-secs (type-break-time-difference
- start-time (current-time))))
- (cond
- ((>= break-secs type-break-good-rest-interval)
- (setq continue nil))
- ;; 60 seconds may be too much leeway if the break is only 3
- ;; minutes to begin with. You can just say "no" to the query
- ;; below if you're in that much of a hurry.
- ;((> 60 (abs (- break-secs type-break-good-rest-interval)))
- ; (setq continue nil))
- ((funcall
- type-break-query-function
- (format "%sYou really ought to rest %s more. Continue break? "
- (type-break-time-stamp)
- (type-break-format-time (- type-break-good-rest-interval
- break-secs)))))
- (t
- (setq continue nil)))))
- (t (setq continue nil)))))
+ (let ((good-interval (or type-break-good-rest-interval
+ type-break-good-break-interval)))
+ (cond
+ (good-interval
+ (let ((break-secs (type-break-time-difference
+ start-time (current-time))))
+ (cond
+ ((>= break-secs good-interval)
+ (setq continue nil))
+ ;; 60 seconds may be too much leeway if the break is only 3
+ ;; minutes to begin with. You can just say "no" to the query
+ ;; below if you're in that much of a hurry.
+ ;;((> 60 (abs (- break-secs good-interval)))
+ ;; (setq continue nil))
+ ((funcall
+ type-break-query-function
+ (format
+ (if type-break-terse-messages
+ "%s%s remaining. Continue break? "
+ "%sYou really ought to rest %s more. Continue break? ")
+ (type-break-time-stamp)
+ (type-break-format-time (- good-interval
+ break-secs)))))
+ (t
+ (setq continue nil)))))
+ (t (setq continue nil))))))
(type-break-keystroke-reset)
+ (type-break-file-time)
(type-break-mode-line-countdown-or-break nil)
(type-break-schedule))
-(defun type-break-schedule (&optional time)
+(defun type-break-schedule (&optional time start interval)
"Schedule a typing break for TIME seconds from now.
-If time is not specified, default to `type-break-interval'."
+If time is not specified it defaults to `type-break-interval'.
+START and INTERVAL are used when recovering a break.
+START is the start of the break (defaults to now).
+INTERVAL is the full length of an interval (defaults to TIME)."
(interactive (list (and current-prefix-arg
(prefix-numeric-value current-prefix-arg))))
(or time (setq time type-break-interval))
@@ -483,7 +659,8 @@ If time is not specified, default to `type-break-interval'."
(type-break-time-warning-schedule time 'reset)
(type-break-run-at-time (max 1 time) nil 'type-break-alarm)
(setq type-break-time-next-break
- (type-break-time-sum (current-time) time)))
+ (type-break-time-sum (or start (current-time))
+ (or interval time))))
(defun type-break-cancel-schedule ()
(type-break-cancel-time-warning-schedule)
@@ -532,6 +709,7 @@ If time is not specified, default to `type-break-interval'."
(remove-hook 'type-break-post-command-hook 'type-break-time-warning)
(setq type-break-current-time-warning-interval
type-break-time-warning-intervals)
+ (setq type-break-time-warning-count 0) ; avoid warnings after break
(setq type-break-warning-countdown-string nil))
(defun type-break-alarm ()
@@ -556,6 +734,7 @@ If time is not specified, default to `type-break-interval'."
This may be the case either because the scheduled time has come \(and the
minimum keystroke threshold has been reached\) or because the maximum
keystroke threshold has been exceeded."
+ (type-break-file-keystroke-count)
(let* ((min-threshold (car type-break-keystroke-threshold))
(max-threshold (cdr type-break-keystroke-threshold)))
(and type-break-good-rest-interval
@@ -657,16 +836,19 @@ keystroke threshold has been exceeded."
;; from taking place before this one has even returned.
;; The condition-case wrapper will reschedule on quit.
(type-break-cancel-schedule)
+ ;; Also prevent a second query when the break is interrupted.
+ (remove-hook 'type-break-post-command-hook 'type-break-do-query)
(funcall type-break-query-function
(format "%s%s"
(type-break-time-stamp)
- "Take a break from typing now? ")))
+ (if type-break-terse-messages
+ "Break now? "
+ "Take a break from typing now? "))))
(type-break))
(t
(type-break-schedule type-break-query-interval)))
(quit
- (type-break-schedule type-break-query-interval)))
- (remove-hook 'type-break-post-command-hook 'type-break-do-query))))
+ (type-break-schedule type-break-query-interval))))))
(defun type-break-noninteractive-query (&optional ignored-args)
"Null query function which doesn't interrupt user and assumes `no'.
@@ -810,7 +992,7 @@ based on a fairly simple algorithm involving assumptions about the average
length of words (5). For the minimum threshold, it uses about a fifth of
the computed maximum threshold.
-When called from lisp programs, the optional args WORDLEN and FRAC can be
+When called from Lisp programs, the optional args WORDLEN and FRAC can be
used to override the default assumption about average word length and the
fraction of the maximum threshold to which to set the minimum threshold.
FRAC should be the inverse of the fractional value; for example, a value of
@@ -891,6 +1073,7 @@ FRAC should be the inverse of the fractional value; for example, a value of
(t (format "%d seconds" secs)))))
(defun type-break-keystroke-reset ()
+ (setq type-break-interval-start (current-time)) ; not a keystroke
(setq type-break-keystroke-count 0)
(setq type-break-keystroke-warning-count 0)
(setq type-break-current-keystroke-warning-interval
@@ -903,7 +1086,7 @@ With optional non-nil ALL, force redisplay of all mode-lines."
(and all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
-;; If an exception occurs in emacs while running the post command hook, the
+;; If an exception occurs in Emacs while running the post command hook, the
;; value of that hook is clobbered. This is because the value of the
;; variable is temporarily set to nil while it's running to prevent
;; recursive application, but it also means an exception aborts the routine
@@ -916,7 +1099,7 @@ With optional non-nil ALL, force redisplay of all mode-lines."
;;; Timer wrapper functions
;;;
;;; These shield type-break from variations in the interval timer packages
-;;; for different versions of emacs.
+;;; for different versions of Emacs.
(defun type-break-run-at-time (time repeat function)
(condition-case nil (or (require 'timer) (require 'itimer)) (error nil))
@@ -1002,44 +1185,83 @@ With optional non-nil ALL, force redisplay of all mode-lines."
;; Boring demo, but doesn't use many cycles
(defun type-break-demo-boring ()
"Boring typing break demo."
- (let ((rmsg "Press any key to resume from typing break")
+ (let ((rmsg (if type-break-terse-messages
+ ""
+ "Press any key to resume from typing break"))
(buffer-name "*Typing Break Buffer*")
- line col pos
- elapsed timeleft tmsg)
+ lines elapsed timeleft tmsg)
(condition-case ()
(progn
(switch-to-buffer (get-buffer-create buffer-name))
(buffer-disable-undo (current-buffer))
- (erase-buffer)
- (setq line (1+ (/ (window-height) 2)))
- (setq col (/ (- (window-width) (length rmsg)) 2))
- (insert (make-string line ?\C-j)
- (make-string col ?\ )
- rmsg)
- (forward-line -1)
- (beginning-of-line)
- (setq pos (point))
+ (setq lines (/ (window-body-height) 2))
+ (unless type-break-terse-messages (setq lines (1- lines)))
+ (if type-break-demo-boring-stats
+ (setq lines (- lines 2)))
+ (setq lines (make-string lines ?\C-j))
(while (not (input-pending-p))
- (delete-region pos (progn
- (goto-char pos)
- (end-of-line)
- (point)))
+ (erase-buffer)
(setq elapsed (type-break-time-difference
type-break-time-last-break
(current-time)))
- (cond
- (type-break-good-rest-interval
- (setq timeleft (- type-break-good-rest-interval elapsed))
- (if (> timeleft 0)
- (setq tmsg (format "You should rest for %s more"
- (type-break-format-time timeleft)))
- (setq tmsg (format "Typing break has lasted %s"
- (type-break-format-time elapsed)))))
- (t
- (setq tmsg (format "Typing break has lasted %s"
- (type-break-format-time elapsed)))))
- (setq col (/ (- (window-width) (length tmsg)) 2))
- (insert (make-string col ?\ ) tmsg)
+ (let ((good-interval (or type-break-good-rest-interval
+ type-break-good-break-interval)))
+ (cond
+ (good-interval
+ (setq timeleft (- good-interval elapsed))
+ (if (> timeleft 0)
+ (setq tmsg
+ (format (if type-break-terse-messages
+ "Break remaining: %s"
+ "You should rest for %s more")
+ (type-break-format-time timeleft)))
+ (setq tmsg
+ (format (if type-break-terse-messages
+ "Break complete (%s elapsed in total)"
+ "Typing break has lasted %s")
+ (type-break-format-time elapsed)))))
+ (t
+ (setq tmsg
+ (format (if type-break-terse-messages
+ "Break has lasted %s"
+ "Typing break has lasted %s")
+ (type-break-format-time elapsed))))))
+ (insert lines
+ (make-string (/ (- (window-width) (length tmsg)) 2) ?\ )
+ tmsg)
+ (if (> (length rmsg) 0)
+ (insert "\n"
+ (make-string (/ (- (window-width) (length rmsg)) 2)
+ ?\ )
+ rmsg))
+ (if type-break-demo-boring-stats
+ (let*
+ ((message
+ (format
+ (if type-break-terse-messages
+ "Since last break: %s keystrokes\n"
+ "Since your last break you've typed %s keystrokes\n")
+ type-break-keystroke-count))
+ (column-spaces
+ (make-string (/ (- (window-width) (length message)) 2)
+ ?\ ))
+ (wpm (/ (/ (float type-break-keystroke-count) 5)
+ (/ (type-break-time-difference
+ type-break-interval-start
+ type-break-time-last-break)
+ 60.0))))
+ (insert "\n\n" column-spaces message)
+ (if type-break-terse-messages
+ (insert (format " %s%.2f wpm"
+ column-spaces
+ wpm))
+ (setq message
+ (format "at an average of %.2f words per minute"
+ wpm))
+ (insert
+ (make-string (/ (- (window-width) (length message)) 2)
+ ?\ )
+ message))))
(goto-char (point-min))
(sit-for 60))
(read-char)
diff --git a/lisp/url/url-dav.el b/lisp/url/url-dav.el
new file mode 100644
index 00000000000..d6c5ffffa43
--- /dev/null
+++ b/lisp/url/url-dav.el
@@ -0,0 +1,983 @@
+;;; url-dav.el --- WebDAV support
+
+;; Copyright (C) 2001, 2004 Free Software Foundation, Inc.
+
+;; Author: Bill Perry <wmperry@gnu.org>
+;; Maintainer: Bill Perry <wmperry@gnu.org>
+;; Keywords: url, vc
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;; DAV is in RFC 2518.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl))
+
+(require 'xml)
+(require 'url-util)
+(require 'url-handlers)
+
+(defvar url-dav-supported-protocols '(1 2)
+ "List of supported DAV versions.")
+
+(defun url-intersection (l1 l2)
+ "Return a list of the elements occuring in both of the lists L1 and L2."
+ (if (null l2)
+ l2
+ (let (result)
+ (while l1
+ (if (member (car l1) l2)
+ (setq result (cons (pop l1) result))
+ (pop l1)))
+ (nreverse result))))
+
+;;;###autoload
+(defun url-dav-supported-p (url)
+ (and (featurep 'xml)
+ (fboundp 'xml-expand-namespace)
+ (url-intersection url-dav-supported-protocols
+ (plist-get (url-http-options url) 'dav))))
+
+(defun url-dav-node-text (node)
+ "Return the text data from the XML node NODE."
+ (mapconcat (lambda (txt)
+ (if (stringp txt)
+ txt
+ "")) (xml-node-children node) " "))
+
+
+;;; Parsing routines for the actual node contents.
+;;
+;; I am not incredibly happy with how this code looks/works right
+;; now, but it DOES work, and if we get the API right, our callers
+;; won't have to worry about the internal representation.
+
+(defconst url-dav-datatype-attribute
+ 'urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/dt)
+
+(defun url-dav-process-integer-property (node)
+ (truncate (string-to-number (url-dav-node-text node))))
+
+(defun url-dav-process-number-property (node)
+ (string-to-number (url-dav-node-text node)))
+
+(defconst url-dav-iso8601-regexp
+ (let* ((dash "-?")
+ (colon ":?")
+ (4digit "\\([0-9][0-9][0-9][0-9]\\)")
+ (2digit "\\([0-9][0-9]\\)")
+ (date-fullyear 4digit)
+ (date-month 2digit)
+ (date-mday 2digit)
+ (time-hour 2digit)
+ (time-minute 2digit)
+ (time-second 2digit)
+ (time-secfrac "\\(\\.[0-9]+\\)?")
+ (time-numoffset (concat "[-+]\\(" time-hour "\\):" time-minute))
+ (time-offset (concat "Z" time-numoffset))
+ (partial-time (concat time-hour colon time-minute colon time-second
+ time-secfrac))
+ (full-date (concat date-fullyear dash date-month dash date-mday))
+ (full-time (concat partial-time time-offset))
+ (date-time (concat full-date "T" full-time)))
+ (list (concat "^" full-date)
+ (concat "T" partial-time)
+ (concat "Z" time-numoffset)))
+ "List of regular expressions matching iso8601 dates.
+1st regular expression matches the date.
+2nd regular expression matches the time.
+3rd regular expression matches the (optional) timezone specification.")
+
+(defun url-dav-process-date-property (node)
+ (require 'parse-time)
+ (let* ((date-re (nth 0 url-dav-iso8601-regexp))
+ (time-re (nth 1 url-dav-iso8601-regexp))
+ (tz-re (nth 2 url-dav-iso8601-regexp))
+ (date-string (url-dav-node-text node))
+ re-start
+ time seconds minute hour fractional-seconds
+ day month year day-of-week dst tz)
+ ;; We need to populate 'time' with
+ ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ)
+
+ ;; Nobody else handles iso8601 correctly, lets do it ourselves.
+ (when (string-match date-re date-string re-start)
+ (setq year (string-to-int (match-string 1 date-string))
+ month (string-to-int (match-string 2 date-string))
+ day (string-to-int (match-string 3 date-string))
+ re-start (match-end 0))
+ (when (string-match time-re date-string re-start)
+ (setq hour (string-to-int (match-string 1 date-string))
+ minute (string-to-int (match-string 2 date-string))
+ seconds (string-to-int (match-string 3 date-string))
+ fractional-seconds (string-to-int (or
+ (match-string 4 date-string)
+ "0"))
+ re-start (match-end 0))
+ (when (string-match tz-re date-string re-start)
+ (setq tz (match-string 1 date-string)))
+ (url-debug 'dav "Parsed iso8601%s date" (if tz "tz" ""))
+ (setq time (list seconds minute hour day month year day-of-week dst tz))))
+
+ ;; Fall back to having Gnus do fancy things for us.
+ (when (not time)
+ (setq time (parse-time-string date-string)))
+
+ (if time
+ (setq time (apply 'encode-time time))
+ (url-debug 'dav "Unable to decode date (%S) (%s)"
+ (xml-node-name node) date-string))
+ time))
+
+(defun url-dav-process-boolean-property (node)
+ (/= 0 (string-to-int (url-dav-node-text node))))
+
+(defun url-dav-process-uri-property (node)
+ ;; Returns a parsed representation of the URL...
+ (url-generic-parse-url (url-dav-node-text node)))
+
+(defun url-dav-find-parser (node)
+ "Find a function to parse the XML node NODE."
+ (or (get (xml-node-name node) 'dav-parser)
+ (let ((fn (intern (format "url-dav-process-%s" (xml-node-name node)))))
+ (if (not (fboundp fn))
+ (setq fn 'url-dav-node-text)
+ (put (xml-node-name node) 'dav-parser fn))
+ fn)))
+
+(defmacro url-dav-dispatch-node (node)
+ `(funcall (url-dav-find-parser ,node) ,node))
+
+(defun url-dav-process-DAV:prop (node)
+ ;; A prop node has content model of ANY
+ ;;
+ ;; Some predefined nodes have special meanings though.
+ ;;
+ ;; DAV:supportedlock - list of DAV:lockentry
+ ;; DAV:source
+ ;; DAV:iscollection - boolean
+ ;; DAV:getcontentlength - integer
+ ;; DAV:ishidden - boolean
+ ;; DAV:getcontenttype - string
+ ;; DAV:resourcetype - node who's name is the resource type
+ ;; DAV:getlastmodified - date
+ ;; DAV:creationdate - date
+ ;; DAV:displayname - string
+ ;; DAV:getetag - unknown
+ (let ((children (xml-node-children node))
+ (node-type nil)
+ (props nil)
+ (value nil)
+ (handler-func nil))
+ (when (not children)
+ (error "No child nodes in DAV:prop"))
+
+ (while children
+ (setq node (car children)
+ node-type (intern
+ (or
+ (cdr-safe (assq url-dav-datatype-attribute
+ (xml-node-attributes node)))
+ "unknown"))
+ value nil)
+
+ (case node-type
+ ((dateTime.iso8601tz
+ dateTime.iso8601
+ dateTime.tz
+ dateTime.rfc1123
+ dateTime
+ date) ; date is our 'special' one...
+ ;; Some type of date/time string.
+ (setq value (url-dav-process-date-property node)))
+ (int
+ ;; Integer type...
+ (setq value (url-dav-process-integer-property node)))
+ ((number float)
+ (setq value (url-dav-process-number-property node)))
+ (boolean
+ (setq value (url-dav-process-boolean-property node)))
+ (uri
+ (setq value (url-dav-process-uri-property node)))
+ (otherwise
+ (if (not (eq node-type 'unknown))
+ (url-debug 'dav "Unknown data type in url-dav-process-prop: %s"
+ node-type))
+ (setq value (url-dav-dispatch-node node))))
+
+ (setq props (plist-put props (xml-node-name node) value)
+ children (cdr children)))
+ props))
+
+(defun url-dav-process-DAV:supportedlock (node)
+ ;; DAV:supportedlock is a list of DAV:lockentry items.
+ ;; DAV:lockentry in turn contains a DAV:lockscope and DAV:locktype.
+ ;; The DAV:lockscope must have a single node beneath it, ditto for
+ ;; DAV:locktype.
+ (let ((children (xml-node-children node))
+ (results nil)
+ scope type)
+ (while children
+ (when (and (not (stringp (car children)))
+ (eq (xml-node-name (car children)) 'DAV:lockentry))
+ (setq scope (assq 'DAV:lockscope (xml-node-children (car children)))
+ type (assq 'DAV:locktype (xml-node-children (car children))))
+ (when (and scope type)
+ (setq scope (xml-node-name (car (xml-node-children scope)))
+ type (xml-node-name (car (xml-node-children type))))
+ (push (cons type scope) results)))
+ (setq children (cdr children)))
+ results))
+
+(defun url-dav-process-subnode-property (node)
+ ;; Returns a list of child node names.
+ (delq nil (mapcar 'car-safe (xml-node-children node))))
+
+(defalias 'url-dav-process-DAV:depth 'url-dav-process-integer-property)
+(defalias 'url-dav-process-DAV:resourcetype 'url-dav-process-subnode-property)
+(defalias 'url-dav-process-DAV:locktype 'url-dav-process-subnode-property)
+(defalias 'url-dav-process-DAV:lockscope 'url-dav-process-subnode-property)
+(defalias 'url-dav-process-DAV:getcontentlength 'url-dav-process-integer-property)
+(defalias 'url-dav-process-DAV:getlastmodified 'url-dav-process-date-property)
+(defalias 'url-dav-process-DAV:creationdate 'url-dav-process-date-property)
+(defalias 'url-dav-process-DAV:iscollection 'url-dav-process-boolean-property)
+(defalias 'url-dav-process-DAV:ishidden 'url-dav-process-boolean-property)
+
+(defun url-dav-process-DAV:locktoken (node)
+ ;; DAV:locktoken can have one or more DAV:href children.
+ (delq nil (mapcar (lambda (n)
+ (if (stringp n)
+ n
+ (url-dav-dispatch-node n)))
+ (xml-node-children node))))
+
+(defun url-dav-process-DAV:owner (node)
+ ;; DAV:owner can contain anything.
+ (delq nil (mapcar (lambda (n)
+ (if (stringp n)
+ n
+ (url-dav-dispatch-node n)))
+ (xml-node-children node))))
+
+(defun url-dav-process-DAV:activelock (node)
+ ;; DAV:activelock can contain:
+ ;; DAV:lockscope
+ ;; DAV:locktype
+ ;; DAV:depth
+ ;; DAV:owner (optional)
+ ;; DAV:timeout (optional)
+ ;; DAV:locktoken (optional)
+ (let ((children (xml-node-children node))
+ (results nil))
+ (while children
+ (if (listp (car children))
+ (push (cons (xml-node-name (car children))
+ (url-dav-dispatch-node (car children)))
+ results))
+ (setq children (cdr children)))
+ results))
+
+(defun url-dav-process-DAV:lockdiscovery (node)
+ ;; Can only contain a list of DAV:activelock objects.
+ (let ((children (xml-node-children node))
+ (results nil))
+ (while children
+ (cond
+ ((stringp (car children))
+ ;; text node? why?
+ nil)
+ ((eq (xml-node-name (car children)) 'DAV:activelock)
+ (push (url-dav-dispatch-node (car children)) results))
+ (t
+ ;; Ignore unknown nodes...
+ nil))
+ (setq children (cdr children)))
+ results))
+
+(defun url-dav-process-DAV:status (node)
+ ;; The node contains a standard HTTP/1.1 response line... we really
+ ;; only care about the numeric status code.
+ (let ((status (url-dav-node-text node)))
+ (if (string-match "\\`[ \r\t\n]*HTTP/[0-9.]+ \\([0-9]+\\)" status)
+ (string-to-int (match-string 1 status))
+ 500)))
+
+(defun url-dav-process-DAV:propstat (node)
+ ;; A propstate node can have the following children...
+ ;;
+ ;; DAV:prop - a list of properties and values
+ ;; DAV:status - An HTTP/1.1 status line
+ (let ((children (xml-node-children node))
+ (props nil)
+ (status nil))
+ (when (not children)
+ (error "No child nodes in DAV:propstat"))
+
+ (setq props (url-dav-dispatch-node (assq 'DAV:prop children))
+ status (url-dav-dispatch-node (assq 'DAV:status children)))
+
+ ;; Need to parse out the HTTP status
+ (setq props (plist-put props 'DAV:status status))
+ props))
+
+(defun url-dav-process-DAV:response (node)
+ (let ((children (xml-node-children node))
+ (propstat nil)
+ (href))
+ (when (not children)
+ (error "No child nodes in DAV:response"))
+
+ ;; A response node can have the following children...
+ ;;
+ ;; DAV:href - URL the response is for.
+ ;; DAV:propstat - see url-dav-process-propstat
+ ;; DAV:responsedescription - text description of the response
+ (setq propstat (assq 'DAV:propstat children)
+ href (assq 'DAV:href children))
+
+ (when (not href)
+ (error "No href in DAV:response"))
+
+ (when (not propstat)
+ (error "No propstat in DAV:response"))
+
+ (setq propstat (url-dav-dispatch-node propstat)
+ href (url-dav-dispatch-node href))
+ (cons href propstat)))
+
+(defun url-dav-process-DAV:multistatus (node)
+ (let ((children (xml-node-children node))
+ (results nil))
+ (while children
+ (push (url-dav-dispatch-node (car children)) results)
+ (setq children (cdr children)))
+ results))
+
+
+;;; DAV request/response generation/processing
+(defun url-dav-process-response (buffer url)
+ "Parse a WebDAV response from BUFFER, interpreting it relative to URL.
+
+The buffer must have been retrieved by HTTP or HTTPS and contain an
+XML document."
+ (declare (special url-http-content-type
+ url-http-response-status
+ url-http-end-of-headers))
+ (let ((tree nil)
+ (overall-status nil))
+ (when buffer
+ (unwind-protect
+ (with-current-buffer buffer
+ (goto-char url-http-end-of-headers)
+ (setq overall-status url-http-response-status)
+
+ ;; XML documents can be transferred as either text/xml or
+ ;; application/xml, and we are required to accept both of
+ ;; them.
+ (if (and
+ url-http-content-type
+ (string-match "\\`\\(text\\|application\\)/xml"
+ url-http-content-type))
+ (setq tree (xml-parse-region (point) (point-max)))))
+ ;; Clean up after ourselves.
+ (kill-buffer buffer)))
+
+ ;; We should now be
+ (if (eq (xml-node-name (car tree)) 'DAV:multistatus)
+ (url-dav-dispatch-node (car tree))
+ (url-debug 'dav "Got back singleton response for URL(%S)" url)
+ (let ((properties (url-dav-dispatch-node (car tree))))
+ ;; We need to make sure we have a DAV:status node in there for
+ ;; higher-level code;
+ (setq properties (plist-put properties 'DAV:status overall-status))
+ ;; Make this look like a DAV:multistatus parse tree so that
+ ;; nobody but us needs to know the difference.
+ (list (cons url properties))))))
+
+(defun url-dav-request (url method tag body
+ &optional depth headers namespaces)
+ "Perform WebDAV operation METHOD on URL. Return the parsed responses.
+Automatically creates an XML request body if TAG is non-nil.
+BODY is the XML document fragment to be enclosed by <TAG></TAG>.
+
+DEPTH is how deep the request should propogate. Default is 0, meaning
+it should apply only to URL. A negative number means to use
+`Infinity' for the depth. Not all WebDAV servers support this depth
+though.
+
+HEADERS is an assoc list of extra headers to send in the request.
+
+NAMESPACES is an assoc list of (NAMESPACE . EXPANSION), and these are
+added to the <TAG> element. The DAV=DAV: namespace is automatically
+added to this list, so most requests can just pass in nil."
+ ;; Take care of the default value for depth...
+ (setq depth (or depth 0))
+
+ ;; Now lets translate it into something webdav can understand.
+ (if (< depth 0)
+ (setq depth "Infinity")
+ (setq depth (int-to-string depth)))
+ (if (not (assoc "DAV" namespaces))
+ (setq namespaces (cons '("DAV" . "DAV:") namespaces)))
+
+ (let* ((url-request-extra-headers `(("Depth" . ,depth)
+ ("Content-type" . "text/xml")
+ ,@headers))
+ (url-request-method method)
+ (url-request-data
+ (if tag
+ (concat
+ "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
+ "<" (symbol-name tag) " "
+ ;; add in the appropriate namespaces...
+ (mapconcat (lambda (ns)
+ (concat "xmlns:" (car ns) "='" (cdr ns) "'"))
+ namespaces "\n ")
+ ">\n"
+ body
+ "</" (symbol-name tag) ">\n"))))
+ (url-dav-process-response (url-retrieve-synchronously url) url)))
+
+;;;###autoload
+(defun url-dav-get-properties (url &optional attributes depth namespaces)
+ "Return properties for URL, up to DEPTH levels deep.
+
+Returns an assoc list, where the key is the filename (possibly a full
+URI), and the value is a standard property list of DAV property
+names (ie: DAV:resourcetype)."
+ (url-dav-request url "PROPFIND" 'DAV:propfind
+ (if attributes
+ (mapconcat (lambda (attr)
+ (concat "<DAV:prop><"
+ (symbol-name attr)
+ "/></DAV:prop>"))
+ attributes "\n ")
+ " <DAV:allprop/>")
+ depth nil namespaces))
+
+(defmacro url-dav-http-success-p (status)
+ "Return whether PROPERTIES was the result of a successful DAV request."
+ `(= (/ (or ,status 500) 100) 2))
+
+
+;;; Locking support
+(defvar url-dav-lock-identifier (concat "mailto:" user-mail-address)
+ "*URL used as contact information when creating locks in DAV.
+This will be used as the contents of the DAV:owner/DAV:href tag to
+identify the owner of a LOCK when requesting it. This will be shown
+to other users when the DAV:lockdiscovery property is requested, so
+make sure you are comfortable with it leaking to the outside world.")
+
+;;;###autoload
+(defun url-dav-lock-resource (url exclusive &optional depth)
+ "Request a lock on URL. If EXCLUSIVE is non-nil, get an exclusive lock.
+Optional 3rd argument DEPTH says how deep the lock should go, default is 0
+\(lock only the resource and none of its children\).
+
+Returns a cons-cell of (SUCCESSFUL-RESULTS . FAILURE-RESULTS).
+SUCCESSFUL-RESULTS is a list of (URL STATUS locktoken).
+FAILURE-RESULTS is a list of (URL STATUS)."
+ (setq exclusive (if exclusive "<DAV:exclusive/>" "<DAV:shared/>"))
+ (let* ((body
+ (concat
+ " <DAV:lockscope>" exclusive "</DAV:lockscope>\n"
+ " <DAV:locktype> <DAV:write/> </DAV:locktype>\n"
+ " <DAV:owner>\n"
+ " <DAV:href>" url-dav-lock-identifier "</DAV:href>\n"
+ " </DAV:owner>\n"))
+ (response nil) ; Responses to the LOCK request
+ (result nil) ; For walking thru the response list
+ (child-url nil)
+ (child-status nil)
+ (failures nil) ; List of failure cases (URL . STATUS)
+ (successes nil)) ; List of success cases (URL . STATUS)
+ (setq response (url-dav-request url "LOCK" 'DAV:lockinfo body
+ depth '(("Timeout" . "Infinite"))))
+
+ ;; Get the parent URL ready for expand-file-name
+ (if (not (vectorp url))
+ (setq url (url-generic-parse-url url)))
+
+ ;; Walk thru the response list, fully expand the URL, and grab the
+ ;; status code.
+ (while response
+ (setq result (pop response)
+ child-url (url-expand-file-name (pop result) url)
+ child-status (or (plist-get result 'DAV:status) 500))
+ (if (url-dav-http-success-p child-status)
+ (push (list url child-status "huh") successes)
+ (push (list url child-status) failures)))
+ (cons successes failures)))
+
+;;;###autoload
+(defun url-dav-active-locks (url &optional depth)
+ "Return an assoc list of all active locks on URL."
+ (let ((response (url-dav-get-properties url '(DAV:lockdiscovery) depth))
+ (properties nil)
+ (child nil)
+ (child-url nil)
+ (child-results nil)
+ (results nil))
+ (if (not (vectorp url))
+ (setq url (url-generic-parse-url url)))
+
+ (while response
+ (setq child (pop response)
+ child-url (pop child)
+ child-results nil)
+ (when (and (url-dav-http-success-p (plist-get child 'DAV:status))
+ (setq child (plist-get child 'DAV:lockdiscovery)))
+ ;; After our parser has had its way with it, The
+ ;; DAV:lockdiscovery property is a list of DAV:activelock
+ ;; objects, which are comprised of DAV:activelocks, which
+ ;; assoc lists of properties and values.
+ (while child
+ (if (assq 'DAV:locktoken (car child))
+ (let ((tokens (cdr (assq 'DAV:locktoken (car child))))
+ (owners (cdr (assq 'DAV:owner (car child)))))
+ (dolist (token tokens)
+ (dolist (owner owners)
+ (push (cons token owner) child-results)))))
+ (pop child)))
+ (if child-results
+ (push (cons (url-expand-file-name child-url url) child-results)
+ results)))
+ results))
+
+;;;###autoload
+(defun url-dav-unlock-resource (url lock-token)
+ "Release the lock on URL represented by LOCK-TOKEN.
+Returns t iff the lock was successfully released."
+ (declare (special url-http-response-status))
+ (let* ((url-request-extra-headers (list (cons "Lock-Token"
+ (concat "<" lock-token ">"))))
+ (url-request-method "UNLOCK")
+ (url-request-data nil)
+ (buffer (url-retrieve-synchronously url))
+ (result nil))
+ (when buffer
+ (unwind-protect
+ (with-current-buffer buffer
+ (setq result (url-dav-http-success-p url-http-response-status)))
+ (kill-buffer buffer)))
+ result))
+
+
+;;; file-name-handler stuff
+(defun url-dav-file-attributes-mode-string (properties)
+ (let ((modes (make-string 10 ?-))
+ (supported-locks (plist-get properties 'DAV:supportedlock))
+ (executable-p (equal (plist-get properties 'http://apache.org/dav/props/executable)
+ "T"))
+ (directory-p (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)))
+ (readable t)
+ (lock nil))
+ ;; Assume we can read this, otherwise the PROPFIND would have
+ ;; failed.
+ (when readable
+ (aset modes 1 ?r)
+ (aset modes 4 ?r)
+ (aset modes 7 ?r))
+
+ (when directory-p
+ (aset modes 0 ?d))
+
+ (when executable-p
+ (aset modes 3 ?x)
+ (aset modes 6 ?x)
+ (aset modes 9 ?x))
+
+ (while supported-locks
+ (setq lock (car supported-locks)
+ supported-locks (cdr supported-locks))
+ (case (car lock)
+ (DAV:write
+ (case (cdr lock)
+ (DAV:shared ; group permissions (possibly world)
+ (aset modes 5 ?w))
+ (DAV:exclusive
+ (aset modes 2 ?w)) ; owner permissions?
+ (otherwise
+ (url-debug 'dav "Unrecognized DAV:lockscope (%S)" (cdr lock)))))
+ (otherwise
+ (url-debug 'dav "Unrecognized DAV:locktype (%S)" (car lock)))))
+ modes))
+
+(autoload 'url-http-head-file-attributes "url-http")
+
+;;;###autoload
+(defun url-dav-file-attributes (url &optional id-format)
+ (let ((properties (cdar (url-dav-get-properties url)))
+ (attributes nil))
+ (if (and properties
+ (url-dav-http-success-p (plist-get properties 'DAV:status)))
+ ;; We got a good DAV response back..
+ (setq attributes
+ (list
+ ;; t for directory, string for symbolic link, or nil
+ ;; Need to support DAV Bindings to figure out the
+ ;; symbolic link issues.
+ (if (memq 'DAV:collection (plist-get properties 'DAV:resourcetype)) t nil)
+
+ ;; Number of links to file... Needs DAV Bindings.
+ 1
+
+ ;; File uid - no way to figure out?
+ 0
+
+ ;; File gid - no way to figure out?
+ 0
+
+ ;; Last access time - ???
+ nil
+
+ ;; Last modification time
+ (plist-get properties 'DAV:getlastmodified)
+
+ ;; Last status change time... just reuse last-modified
+ ;; for now.
+ (plist-get properties 'DAV:getlastmodified)
+
+ ;; size in bytes
+ (or (plist-get properties 'DAV:getcontentlength) 0)
+
+ ;; file modes as a string like `ls -l'
+ ;;
+ ;; Should be able to build this up from the
+ ;; DAV:supportedlock attribute pretty easily. Getting
+ ;; the group info could be impossible though.
+ (url-dav-file-attributes-mode-string properties)
+
+ ;; t iff file's gid would change if it were deleted &
+ ;; recreated. No way for us to know that thru DAV.
+ nil
+
+ ;; inode number - meaningless
+ nil
+
+ ;; device number - meaningless
+ nil))
+ ;; Fall back to just the normal http way of doing things.
+ (setq attributes (url-http-head-file-attributes url id-format)))
+ attributes))
+
+;;;###autoload
+(defun url-dav-save-resource (url obj &optional content-type lock-token)
+ "Save OBJ as URL using WebDAV.
+URL must be a fully qualified URL.
+OBJ may be a buffer or a string."
+ (declare (special url-http-response-status))
+ (let ((buffer nil)
+ (result nil)
+ (url-request-extra-headers nil)
+ (url-request-method "PUT")
+ (url-request-data
+ (cond
+ ((bufferp obj)
+ (with-current-buffer obj
+ (buffer-string)))
+ ((stringp obj)
+ obj)
+ (t
+ (error "Invalid object to url-dav-save-resource")))))
+
+ (if lock-token
+ (push
+ (cons "If" (concat "(<" lock-token ">)"))
+ url-request-extra-headers))
+
+ ;; Everything must always have a content-type when we submit it.
+ (push
+ (cons "Content-type" (or content-type "application/octet-stream"))
+ url-request-extra-headers)
+
+ ;; Do the save...
+ (setq buffer (url-retrieve-synchronously url))
+
+ ;; Sanity checking
+ (when buffer
+ (unwind-protect
+ (with-current-buffer buffer
+ (setq result (url-dav-http-success-p url-http-response-status)))
+ (kill-buffer buffer)))
+ result))
+
+(eval-when-compile
+ (defmacro url-dav-delete-something (url lock-token &rest error-checking)
+ "Delete URL completely, with no sanity checking whatsoever. DO NOT USE.
+This is defined as a macro that will not be visible from compiled files.
+Use with care, and even then think three times.
+"
+ `(progn
+ ,@error-checking
+ (url-dav-request ,url "DELETE" nil nil -1
+ (if ,lock-token
+ (list
+ (cons "If"
+ (concat "(<" ,lock-token ">)"))))))))
+
+
+;;;###autoload
+(defun url-dav-delete-directory (url &optional recursive lock-token)
+ "Delete the WebDAV collection URL.
+If optional second argument RECURSIVE is non-nil, then delete all
+files in the collection as well."
+ (let ((status nil)
+ (props nil)
+ (props nil))
+ (setq props (url-dav-delete-something
+ url lock-token
+ (setq props (url-dav-get-properties url '(DAV:getcontenttype) 1))
+ (if (and (not recursive)
+ (/= (length props) 1))
+ (signal 'file-error (list "Removing directory"
+ "directory not empty" url)))))
+
+ (mapc (lambda (result)
+ (setq status (plist-get (cdr result) 'DAV:status))
+ (if (not (url-dav-http-success-p status))
+ (signal 'file-error (list "Removing directory"
+ "Errror removing"
+ (car result) status))))
+ props))
+ nil)
+
+;;;###autoload
+(defun url-dav-delete-file (url &optional lock-token)
+ "Delete file named URL."
+ (let ((props nil)
+ (status nil))
+ (setq props (url-dav-delete-something
+ url lock-token
+ (setq props (url-dav-get-properties url))
+ (if (eq (plist-get (cdar props) 'DAV:resourcetype) 'DAV:collection)
+ (signal 'file-error (list "Removing old name" "is a collection" url)))))
+
+ (mapc (lambda (result)
+ (setq status (plist-get (cdr result) 'DAV:status))
+ (if (not (url-dav-http-success-p status))
+ (signal 'file-error (list "Removing old name"
+ "Errror removing"
+ (car result) status))))
+ props))
+ nil)
+
+;;;###autoload
+(defun url-dav-directory-files (url &optional full match nosort files-only)
+ "Return a list of names of files in DIRECTORY.
+There are three optional arguments:
+If FULL is non-nil, return absolute file names. Otherwise return names
+ that are relative to the specified directory.
+If MATCH is non-nil, mention only file names that match the regexp MATCH.
+If NOSORT is non-nil, the list is not sorted--its order is unpredictable.
+ NOSORT is useful if you plan to sort the result yourself."
+ (let ((properties (url-dav-get-properties url '(DAV:resourcetype) 1))
+ (child-url nil)
+ (child-props nil)
+ (files nil)
+ (parsed-url (url-generic-parse-url url)))
+
+ (if (= (length properties) 1)
+ (signal 'file-error (list "Opening directory" "not a directory" url)))
+
+ (while properties
+ (setq child-props (pop properties)
+ child-url (pop child-props))
+ (if (and (eq (plist-get child-props 'DAV:resourcetype) 'DAV:collection)
+ files-only)
+ ;; It is a directory, and we were told to return just files.
+ nil
+
+ ;; Fully expand the URL and then rip off the beginning if we
+ ;; are not supposed to return fully-qualified names.
+ (setq child-url (url-expand-file-name child-url parsed-url))
+ (if (not full)
+ (setq child-url (substring child-url (length url))))
+
+ ;; We don't want '/' as the last character in filenames...
+ (if (string-match "/$" child-url)
+ (setq child-url (substring child-url 0 -1)))
+
+ ;; If we have a match criteria, then apply it.
+ (if (or (and match (not (string-match match child-url)))
+ (string= child-url "")
+ (string= child-url url))
+ nil
+ (push child-url files))))
+
+ (if nosort
+ files
+ (sort files 'string-lessp))))
+
+;;;###autoload
+(defun url-dav-file-directory-p (url)
+ "Return t if URL names an existing DAV collection."
+ (let ((properties (cdar (url-dav-get-properties url '(DAV:resourcetype)))))
+ (eq (plist-get properties 'DAV:resourcetype) 'DAV:collection)))
+
+;;;###autoload
+(defun url-dav-make-directory (url &optional parents)
+ "Create the directory DIR and any nonexistent parent dirs."
+ (declare (special url-http-response-status))
+ (let* ((url-request-extra-headers nil)
+ (url-request-method "MKCOL")
+ (url-request-data nil)
+ (buffer (url-retrieve-synchronously url))
+ (result nil))
+ (when buffer
+ (unwind-protect
+ (with-current-buffer buffer
+ (case url-http-response-status
+ (201 ; Collection created in its entirety
+ (setq result t))
+ (403 ; Forbidden
+ nil)
+ (405 ; Method not allowed
+ nil)
+ (409 ; Conflict
+ nil)
+ (415 ; Unsupported media type (WTF?)
+ nil)
+ (507 ; Insufficient storage
+ nil)
+ (otherwise
+ nil)))
+ (kill-buffer buffer)))
+ result))
+
+;;;###autoload
+(defun url-dav-rename-file (oldname newname &optional overwrite)
+ (if (not (and (string-match url-handler-regexp oldname)
+ (string-match url-handler-regexp newname)))
+ (signal 'file-error
+ (list "Cannot rename between different URL backends"
+ oldname newname)))
+
+ (let* ((headers nil)
+ (props nil)
+ (status nil)
+ (directory-p (url-dav-file-directory-p oldname))
+ (exists-p (url-http-file-exists-p newname)))
+
+ (if (and exists-p
+ (or
+ (null overwrite)
+ (and (numberp overwrite)
+ (not (yes-or-no-p
+ (format "File %s already exists; rename to it anyway? "
+ newname))))))
+ (signal 'file-already-exists (list "File already exists" newname)))
+
+ ;; Honor the overwrite flag...
+ (if overwrite (push '("Overwrite" . "T") headers))
+
+ ;; Have to tell them where to copy it to!
+ (push (cons "Destination" newname) headers)
+
+ ;; Always send a depth of -1 in case we are moving a collection.
+ (setq props (url-dav-request oldname "MOVE" nil nil (if directory-p -1 0)
+ headers))
+
+ (mapc (lambda (result)
+ (setq status (plist-get (cdr result) 'DAV:status))
+
+ (if (not (url-dav-http-success-p status))
+ (signal 'file-error (list "Renaming" oldname newname status))))
+ props)
+ t))
+
+;;;###autoload
+(defun url-dav-file-name-all-completions (file url)
+ "Return a list of all completions of file name FILE in directory DIRECTORY.
+These are all file names in directory DIRECTORY which begin with FILE."
+ (url-dav-directory-files url nil (concat "^" file ".*")))
+
+;;;###autoload
+(defun url-dav-file-name-completion (file url)
+ "Complete file name FILE in directory DIRECTORY.
+Returns the longest string
+common to all file names in DIRECTORY that start with FILE.
+If there is only one and FILE matches it exactly, returns t.
+Returns nil if DIR contains no name starting with FILE."
+ (let ((matches (url-dav-file-name-all-completions file url))
+ (result nil))
+ (cond
+ ((null matches)
+ ;; No matches
+ nil)
+ ((and (= (length matches) 1)
+ (string= file (car matches)))
+ ;; Only one file and FILE matches it exactly...
+ t)
+ (t
+ ;; Need to figure out the longest string that they have in commmon
+ (setq matches (sort matches (lambda (a b) (> (length a) (length b)))))
+ (let ((n (length file))
+ (searching t)
+ (regexp nil)
+ (failed nil))
+ (while (and searching
+ (< n (length (car matches))))
+ (setq regexp (concat "^" (substring (car matches) 0 (1+ n)))
+ failed nil)
+ (dolist (potential matches)
+ (if (not (string-match regexp potential))
+ (setq failed t)))
+ (if failed
+ (setq searching nil)
+ (incf n)))
+ (substring (car matches) 0 n))))))
+
+(defun url-dav-register-handler (op)
+ (put op 'url-file-handlers (intern-soft (format "url-dav-%s" op))))
+
+(mapcar 'url-dav-register-handler
+ '(file-name-all-completions
+ file-name-completion
+ rename-file
+ make-directory
+ file-directory-p
+ directory-files
+ delete-file
+ delete-directory
+ file-attributes))
+
+
+;;; Version Control backend cruft
+
+;(put 'vc-registered 'url-file-handlers 'url-dav-vc-registered)
+
+;;;###autoload
+(defun url-dav-vc-registered (url)
+ (if (and (string-match "\\`https?" url)
+ (plist-get (url-http-options url) 'dav))
+ (progn
+ (vc-file-setprop url 'vc-backend 'dav)
+ t)))
+
+
+;;; Miscellaneous stuff.
+
+(provide 'url-dav)
+
+;; arch-tag: 2b14b7b3-888a-49b8-a490-17276a40e78e
+;;; url-dav.el ends here
diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el
new file mode 100644
index 00000000000..77c2e74555f
--- /dev/null
+++ b/lisp/url/url-file.el
@@ -0,0 +1,245 @@
+;;; url-file.el --- File retrieval code
+
+;; Copyright (c) 1996 - 1999,2004 Free Software Foundation, Inc.
+;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
+
+;; Keywords: comm, data, processes
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'mailcap)
+(require 'url-vars)
+(require 'url-parse)
+(require 'url-dired)
+
+(defconst url-file-default-port 21 "Default FTP port.")
+(defconst url-file-asynchronous-p t "FTP transfers are asynchronous.")
+(defalias 'url-file-expand-file-name 'url-default-expander)
+
+(defun url-file-find-possibly-compressed-file (fname &rest args)
+ "Find the exact file referenced by `fname'.
+This tries the common compression extensions, because things like
+ange-ftp and efs are not quite smart enough to realize when a server
+can do automatic decompression for them, and won't find 'foo' if
+'foo.gz' exists, even though the ftp server would happily serve it up
+to them."
+ (let ((scratch nil)
+ (compressed-extensions '("" ".gz" ".z" ".Z" ".bz2"))
+ (found nil))
+ (while (and compressed-extensions (not found))
+ (if (file-exists-p (setq scratch (concat fname (pop compressed-extensions))))
+ (setq found scratch)))
+ found))
+
+(defun url-file-host-is-local-p (host)
+ "Return t iff HOST references our local machine."
+ (let ((case-fold-search t))
+ (or
+ (null host)
+ (string= "" host)
+ (equal (downcase host) (downcase (system-name)))
+ (and (string-match "^localhost$" host) t)
+ (and (not (string-match (regexp-quote ".") host))
+ (equal (downcase host) (if (string-match (regexp-quote ".")
+ (system-name))
+ (substring (system-name) 0
+ (match-beginning 0))
+ (system-name)))))))
+
+(defun url-file-asynch-callback (x y name buff func args &optional efs)
+ (if (not (featurep 'ange-ftp))
+ ;; EFS passes us an extra argument
+ (setq name buff
+ buff func
+ func args
+ args efs))
+ (let ((size (nth 7 (file-attributes name))))
+ (save-excursion
+ (set-buffer buff)
+ (goto-char (point-max))
+ (if (/= -1 size)
+ (insert (format "Content-length: %d\n" size)))
+ (insert "\n")
+ (insert-file-contents-literally name)
+ (if (not (url-file-host-is-local-p (url-host url-current-object)))
+ (condition-case ()
+ (delete-file name)
+ (error nil)))
+ (apply func args))))
+
+(defun url-file-build-filename (url)
+ (if (not (vectorp url))
+ (setq url (url-generic-parse-url url)))
+ (let* ((user (url-user url))
+ (pass (url-password url))
+ (port (url-port url))
+ (host (url-host url))
+ (site (if (and port (/= port 21))
+ (if (featurep 'ange-ftp)
+ (format "%s %d" host port)
+ ;; This works in Emacs 21's ange-ftp too.
+ (format "%s#%d" host port))
+ host))
+ (file (url-unhex-string (url-filename url)))
+ (filename (if (or user (not (url-file-host-is-local-p host)))
+ (concat "/" (or user "anonymous") "@" site ":" file)
+ (if (and (memq system-type
+ '(emx ms-dos windows-nt ms-windows))
+ (string-match "^/[a-zA-Z]:/" file))
+ (substring file 1)
+ file)))
+ pos-index)
+
+ (and user pass
+ (cond
+ ((featurep 'ange-ftp)
+ (ange-ftp-set-passwd host user pass))
+ ((or (featurep 'efs) (featurep 'efs-auto))
+ (efs-set-passwd host user pass))
+ (t
+ nil)))
+
+ ;; This makes sure that directories have a trailing directory
+ ;; separator on them so URL expansion works right.
+ ;;
+ ;; FIXME? What happens if the remote system doesn't use our local
+ ;; directory-sep-char as its separator? Would it be safer to just
+ ;; use '/' unconditionally and rely on the FTP server to
+ ;; straighten it out for us?
+ ;; (if (and (file-directory-p filename)
+ ;; (not (string-match (format "%c$" directory-sep-char) filename)))
+ ;; (url-set-filename url (format "%s%c" filename directory-sep-char)))
+ (if (and (file-directory-p filename)
+ (not (string-match "/\\'" filename)))
+ (url-set-filename url (format "%s/" filename)))
+
+
+ ;; If it is a directory, look for an index file first.
+ (if (and (file-directory-p filename)
+ url-directory-index-file
+ (setq pos-index (expand-file-name url-directory-index-file filename))
+ (file-exists-p pos-index)
+ (file-readable-p pos-index))
+ (setq filename pos-index))
+
+ ;; Find the (possibly compressed) file
+ (setq filename (url-file-find-possibly-compressed-file filename))
+ filename))
+
+;;;###autoload
+(defun url-file (url callback cbargs)
+ "Handle file: and ftp: URLs."
+ (let* ((buffer nil)
+ (uncompressed-filename nil)
+ (content-type nil)
+ (content-encoding nil)
+ (coding-system-for-read 'binary))
+
+ (setq filename (url-file-build-filename url))
+
+ (if (not filename)
+ (error "File does not exist: %s" (url-recreate-url url)))
+
+ ;; Need to figure out the content-type from the real extension,
+ ;; not the compressed one.
+ (setq uncompressed-filename (if (string-match "\\.\\(gz\\|Z\\|z\\)$" filename)
+ (substring filename 0 (match-beginning 0))
+ filename))
+ (setq content-type (mailcap-extension-to-mime
+ (url-file-extension uncompressed-filename))
+ content-encoding (case (intern (url-file-extension filename))
+ ((\.z \.gz) "gzip")
+ (\.Z "compress")
+ (\.uue "x-uuencoded")
+ (\.hqx "x-hqx")
+ (\.bz2 "x-bzip2")
+ (otherwise nil)))
+
+ (if (file-directory-p filename)
+ ;; A directory is done the same whether we are local or remote
+ (url-find-file-dired filename)
+ (save-excursion
+ (setq buffer (generate-new-buffer " *url-file*"))
+ (set-buffer buffer)
+ (mm-disable-multibyte)
+ (setq url-current-object url)
+ (insert "Content-type: " (or content-type "application/octet-stream") "\n")
+ (if content-encoding
+ (insert "Content-transfer-encoding: " content-encoding "\n"))
+ (if (url-file-host-is-local-p (url-host url))
+ ;; Local files are handled slightly oddly
+ (if (featurep 'ange-ftp)
+ (url-file-asynch-callback nil nil
+ filename
+ (current-buffer)
+ callback cbargs)
+ (url-file-asynch-callback nil nil nil
+ filename
+ (current-buffer)
+ callback cbargs))
+ ;; FTP handling
+ (let* ((extension (url-file-extension filename))
+ (new (url-generate-unique-filename
+ (and (> (length extension) 0)
+ (concat "%s." extension)))))
+ (if (featurep 'ange-ftp)
+ (ange-ftp-copy-file-internal filename (expand-file-name new) t
+ nil t
+ (list 'url-file-asynch-callback
+ 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))))))
+ buffer))
+
+(defmacro url-file-create-wrapper (method args)
+ `(defalias ',(intern (format "url-ftp-%s" method))
+ (defun ,(intern (format "url-file-%s" method)) ,args
+ ,(format "FTP/FILE URL wrapper around `%s' call." method)
+ (setq url (url-file-build-filename url))
+ (and url (,method ,@(remove '&rest (remove '&optional args)))))))
+
+(url-file-create-wrapper file-exists-p (url))
+(url-file-create-wrapper file-attributes (url &optional id-format))
+(url-file-create-wrapper file-symlink-p (url))
+(url-file-create-wrapper file-readable-p (url))
+(url-file-create-wrapper file-writable-p (url))
+(url-file-create-wrapper file-executable-p (url))
+(if (featurep 'xemacs)
+ (progn
+ (url-file-create-wrapper directory-files (url &optional full match nosort files-only))
+ (url-file-create-wrapper file-truename (url &optional default)))
+ (url-file-create-wrapper directory-files (url &optional full match nosort))
+ (url-file-create-wrapper file-truename (url &optional counter prev-dirs)))
+
+(provide 'url-file)
+
+;; arch-tag: 010e914a-7313-494b-8a8c-6495a862157d
+;;; url-file.el ends here
diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el
new file mode 100644
index 00000000000..6c540e8d61b
--- /dev/null
+++ b/lisp/url/url-handlers.el
@@ -0,0 +1,258 @@
+;;; url-handlers.el --- file-name-handler stuff for URL loading
+
+;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc.
+;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
+
+;; Keywords: comm, data, processes, hypermedia
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'url)
+(require 'url-parse)
+(require 'url-util)
+(require 'mm-decode)
+(require 'mailcap)
+
+(eval-when-compile
+ (require 'cl))
+
+;; Implementation status
+;; ---------------------
+;; Function Status
+;; ------------------------------------------------------------
+;; add-name-to-file Needs DAV Bindings
+;; copy-file Broken (assumes 1st item is URL)
+;; delete-directory Finished (DAV)
+;; delete-file Finished (DAV)
+;; diff-latest-backup-file
+;; directory-file-name unnecessary (what about VMS)?
+;; directory-files Finished (DAV)
+;; dired-call-process
+;; dired-compress-file
+;; dired-uncache
+;; expand-file-name Finished
+;; file-accessible-directory-p
+;; file-attributes Finished, better with DAV
+;; file-directory-p Needs DAV, finished
+;; file-executable-p Finished
+;; file-exists-p Finished
+;; file-local-copy
+;; file-modes
+;; file-name-all-completions Finished (DAV)
+;; file-name-as-directory
+;; file-name-completion Finished (DAV)
+;; file-name-directory
+;; file-name-nondirectory
+;; file-name-sans-versions why?
+;; file-newer-than-file-p
+;; file-ownership-preserved-p No way to know
+;; file-readable-p Finished
+;; file-regular-p !directory_p
+;; file-symlink-p Needs DAV bindings
+;; file-truename Needs DAV bindings
+;; file-writable-p Check for LOCK?
+;; find-backup-file-name why?
+;; get-file-buffer why?
+;; insert-directory Use DAV
+;; insert-file-contents Finished
+;; load
+;; make-directory Finished (DAV)
+;; make-symbolic-link Needs DAV bindings
+;; rename-file Finished (DAV)
+;; set-file-modes Use mod_dav specific executable flag?
+;; set-visited-file-modtime Impossible?
+;; shell-command Impossible?
+;; unhandled-file-name-directory
+;; vc-registered Finished (DAV)
+;; verify-visited-file-modtime
+;; write-region
+
+(defvar url-handler-regexp
+ "\\`\\(https?\\|ftp\\|file\\|nfs\\)://"
+ "*A regular expression for matching URLs handled by file-name-handler-alist.
+Some valid URL protocols just do not make sense to visit interactively
+\(about, data, info, irc, mailto, etc\). This regular expression
+avoids conflicts with local files that look like URLs \(Gnus is
+particularly bad at this\).")
+
+;;;###autoload
+(define-minor-mode url-handler-mode
+ "Use URL to handle URL-like file names."
+ :global t
+ (if (not (boundp 'file-name-handler-alist))
+ ;; Can't be turned ON anyway.
+ (setq url-handler-mode nil)
+ ;; Remove old entry, if any.
+ (setq file-name-handler-alist
+ (delq (rassq 'url-file-handler file-name-handler-alist)
+ file-name-handler-alist))
+ (if url-handler-mode
+ (push (cons url-handler-regexp 'url-file-handler)
+ file-name-handler-alist))))
+
+(defun url-run-real-handler (operation args)
+ (let ((inhibit-file-name-handlers (cons 'url-file-handler
+ (if (eq operation inhibit-file-name-operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
+
+(defun url-file-handler (operation &rest args)
+ "Function called from the `file-name-handler-alist' routines.
+OPERATION is what needs to be done (`file-exists-p', etc). ARGS are
+the arguments that would have been passed to OPERATION."
+ (let ((fn (or (get operation 'url-file-handlers)
+ (intern-soft (format "url-%s" operation))))
+ (val nil)
+ (hooked nil))
+ (if (and fn (fboundp fn))
+ (setq hooked t
+ val (apply fn args))
+ (setq hooked nil
+ val (url-run-real-handler operation args)))
+ (url-debug 'handlers "%s %S%S => %S" (if hooked "Hooked" "Real")
+ operation args val)
+ val))
+
+(defun url-file-handler-identity (&rest args)
+ ;; Identity function
+ (car args))
+
+;; These are operations that we can fully support
+(put 'file-readable-p 'url-file-handlers 'url-file-exists-p)
+(put 'substitute-in-file-name 'url-file-handlers 'url-file-handler-identity)
+(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
+(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
+
+;; These are operations that we do not support yet (DAV!!!)
+(put 'file-writable-p 'url-file-handlers 'ignore)
+(put 'file-symlink-p 'url-file-handlers 'ignore)
+
+(defun url-handler-expand-file-name (file &optional base)
+ (if (file-name-absolute-p file)
+ (expand-file-name file "/")
+ (url-expand-file-name file base)))
+
+;; The actual implementation
+;;;###autoload
+(defun url-copy-file (url newname &optional ok-if-already-exists keep-time)
+ "Copy URL to NEWNAME. Both args must be strings.
+Signals a `file-already-exists' error if file NEWNAME already exists,
+unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
+A number as third arg means request confirmation if NEWNAME already exists.
+This is what happens in interactive use with M-x.
+Fourth arg KEEP-TIME non-nil means give the new file the same
+last-modified time as the old one. (This works on only some systems.)
+A prefix arg makes KEEP-TIME non-nil."
+ (if (and (file-exists-p newname)
+ (not ok-if-already-exists))
+ (error "Opening output file: File already exists, %s" newname))
+ (let ((buffer (url-retrieve-synchronously url))
+ (handle nil))
+ (if (not buffer)
+ (error "Opening input file: No such file or directory, %s" url))
+ (save-excursion
+ (set-buffer buffer)
+ (setq handle (mm-dissect-buffer t)))
+ (mm-save-part-to-file handle newname)
+ (kill-buffer buffer)
+ (mm-destroy-parts handle)))
+
+;;;###autoload
+(defun url-file-local-copy (url &rest ignored)
+ "Copy URL into a temporary file on this machine.
+Returns the name of the local copy, or nil, if FILE is directly
+accessible."
+ (let ((filename (make-temp-name "url")))
+ (url-copy-file url filename)
+ filename))
+
+;;;###autoload
+(defun url-insert-file-contents (url &optional visit beg end replace)
+ (let ((buffer (url-retrieve-synchronously url))
+ (handle nil)
+ (data nil))
+ (if (not buffer)
+ (error "Opening input file: No such file or directory, %s" url))
+ (if visit (setq buffer-file-name url))
+ (save-excursion
+ (set-buffer buffer)
+ (setq handle (mm-dissect-buffer t))
+ (set-buffer (mm-handle-buffer handle))
+ (if beg
+ (setq data (buffer-substring beg end))
+ (setq data (buffer-string))))
+ (kill-buffer buffer)
+ (mm-destroy-parts handle)
+ (if replace (delete-region (point-min) (point-max)))
+ (save-excursion
+ (insert data))
+ (list url (length data))))
+
+(defun url-file-name-completion (url directory)
+ (error "Unimplemented"))
+
+(defun url-file-name-all-completions (file directory)
+ (error "Unimplemented"))
+
+;; All other handlers map onto their respective backends.
+(defmacro url-handlers-create-wrapper (method args)
+ `(defun ,(intern (format "url-%s" method)) ,args
+ ,(format "URL file-name-handler wrapper for `%s' call.\n---\n%s" method
+ (or (documentation method t) "No original documentation."))
+ (setq url (url-generic-parse-url url))
+ (when (url-type url)
+ (funcall (url-scheme-get-property (url-type url) (quote ,method))
+ ,@(remove '&rest (remove '&optional args))))))
+
+(url-handlers-create-wrapper file-exists-p (url))
+(url-handlers-create-wrapper file-attributes (url &optional id-format))
+(url-handlers-create-wrapper file-symlink-p (url))
+(url-handlers-create-wrapper file-writable-p (url))
+(url-handlers-create-wrapper file-directory-p (url))
+(url-handlers-create-wrapper file-executable-p (url))
+
+(if (featurep 'xemacs)
+ (progn
+ ;; XEmacs specific prototypes
+ (url-handlers-create-wrapper
+ directory-files (url &optional full match nosort files-only))
+ (url-handlers-create-wrapper
+ file-truename (url &optional default)))
+ ;; Emacs specific prototypes
+ (url-handlers-create-wrapper
+ directory-files (url &optional full match nosort))
+ (url-handlers-create-wrapper
+ file-truename (url &optional counter prev-dirs)))
+
+(add-hook 'find-file-hook 'url-handlers-set-buffer-mode)
+
+(defun url-handlers-set-buffer-mode ()
+ "Set correct modes for the current buffer if visiting a remote file."
+ (and (stringp buffer-file-name)
+ (string-match url-handler-regexp buffer-file-name)
+ (auto-save-mode 0)))
+
+(provide 'url-handlers)
+
+;; arch-tag: 7300b99c-cc83-42ff-9147-79b2723c62ac
+;;; url-handlers.el ends here
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
new file mode 100644
index 00000000000..200025c3804
--- /dev/null
+++ b/lisp/url/url-http.el
@@ -0,0 +1,1224 @@
+;;; url-http.el --- HTTP retrieval routines
+
+;; Copyright (c) 1999, 2001, 2004 Free Software Foundation, Inc.
+
+;; Author: Bill Perry <wmperry@gnu.org>
+;; Keywords: comm, data, processes
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl)
+ (defvar url-http-extra-headers))
+(require 'url-gw)
+(require 'url-util)
+(require 'url-parse)
+(require 'url-cookie)
+(require 'mail-parse)
+(require 'url-auth)
+(autoload 'url-retrieve-synchronously "url")
+(autoload 'url-retrieve "url")
+(autoload 'url-cache-create-filename "url-cache")
+(autoload 'url-mark-buffer-as-dead "url")
+
+(defconst url-http-default-port 80 "Default HTTP port.")
+(defconst url-http-asynchronous-p t "HTTP retrievals are asynchronous.")
+(defalias 'url-http-expand-file-name 'url-default-expander)
+
+(defvar url-http-real-basic-auth-storage nil)
+(defvar url-http-proxy-basic-auth-storage nil)
+
+(defvar url-http-open-connections (make-hash-table :test 'equal
+ :size 17)
+ "A hash table of all open network connections.")
+
+(defvar url-http-version "1.1"
+ "What version of HTTP we advertise, as a string.
+Valid values are 1.1 and 1.0.
+This is only useful when debugging the HTTP subsystem.
+
+Setting this to 1.0 will tell servers not to send chunked encoding,
+and other HTTP/1.1 specific features.
+")
+
+(defvar url-http-attempt-keepalives t
+ "Whether to use a single TCP connection multiple times in HTTP.
+This is only useful when debugging the HTTP subsystem. Setting to
+`nil' will explicitly close the connection to the server after every
+request.
+")
+
+;(eval-when-compile
+;; These are all macros so that they are hidden from external sight
+;; when the file is byte-compiled.
+;;
+;; This allows us to expose just the entry points we want.
+
+;; These routines will allow us to implement persistent HTTP
+;; connections.
+(defsubst url-http-debug (&rest args)
+ (if quit-flag
+ (let ((proc (get-buffer-process (current-buffer))))
+ ;; The user hit C-g, honor it! Some things can get in an
+ ;; incredibly tight loop (chunked encoding)
+ (if proc
+ (progn
+ (set-process-sentinel proc nil)
+ (set-process-filter proc nil)))
+ (error "Transfer interrupted!")))
+ (apply 'url-debug 'http args))
+
+(defun url-http-mark-connection-as-busy (host port proc)
+ (url-http-debug "Marking connection as busy: %s:%d %S" host port proc)
+ (puthash (cons host port)
+ (delq proc (gethash (cons host port) url-http-open-connections))
+ url-http-open-connections)
+ proc)
+
+(defun url-http-mark-connection-as-free (host port proc)
+ (url-http-debug "Marking connection as free: %s:%d %S" host port proc)
+ (set-process-buffer proc nil)
+ (set-process-sentinel proc 'url-http-idle-sentinel)
+ (puthash (cons host port)
+ (cons proc (gethash (cons host port) url-http-open-connections))
+ url-http-open-connections)
+ nil)
+
+(defun url-http-find-free-connection (host port)
+ (let ((conns (gethash (cons host port) url-http-open-connections))
+ (found nil))
+ (while (and conns (not found))
+ (if (not (memq (process-status (car conns)) '(run open)))
+ (progn
+ (url-http-debug "Cleaning up dead process: %s:%d %S"
+ host port (car conns))
+ (url-http-idle-sentinel (car conns) nil))
+ (setq found (car conns))
+ (url-http-debug "Found existing connection: %s:%d %S" host port found))
+ (pop conns))
+ (if found
+ (url-http-debug "Reusing existing connection: %s:%d" host port)
+ (url-http-debug "Contacting host: %s:%d" host port))
+ (url-lazy-message "Contacting host: %s:%d" host port)
+ (url-http-mark-connection-as-busy host port
+ (or found
+ (url-open-stream host nil host
+ port)))))
+
+;; Building an HTTP request
+(defun url-http-user-agent-string ()
+ (if (or (eq url-privacy-level 'paranoid)
+ (and (listp url-privacy-level)
+ (memq 'agent url-privacy-level)))
+ ""
+ (format "User-Agent: %sURL/%s%s\r\n"
+ (if url-package-name
+ (concat url-package-name "/" url-package-version " ")
+ "")
+ url-version
+ (cond
+ ((and url-os-type url-system-type)
+ (concat " (" url-os-type "; " url-system-type ")"))
+ ((or url-os-type url-system-type)
+ (concat " (" (or url-system-type url-os-type) ")"))
+ (t "")))))
+
+(defun url-http-create-request (url &optional ref-url)
+ "Create an HTTP request for URL, referred to by REF-URL."
+ (declare (special proxy-object proxy-info))
+ (let* ((extra-headers)
+ (request nil)
+ (no-cache (cdr-safe (assoc "Pragma" url-request-extra-headers)))
+ (proxy-obj (and (boundp 'proxy-object) proxy-object))
+ (proxy-auth (if (or (cdr-safe (assoc "Proxy-Authorization"
+ url-request-extra-headers))
+ (not proxy-obj))
+ nil
+ (let ((url-basic-auth-storage
+ 'url-http-proxy-basic-auth-storage))
+ (url-get-authentication url nil 'any nil))))
+ (real-fname (if proxy-obj (url-recreate-url proxy-obj)
+ (url-filename url)))
+ (host (url-host (or proxy-obj url)))
+ (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers))
+ nil
+ (url-get-authentication (or
+ (and (boundp 'proxy-info)
+ proxy-info)
+ url) nil 'any nil))))
+ (if (equal "" real-fname)
+ (setq real-fname "/"))
+ (setq no-cache (and no-cache (string-match "no-cache" no-cache)))
+ (if auth
+ (setq auth (concat "Authorization: " auth "\r\n")))
+ (if proxy-auth
+ (setq proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n")))
+
+ ;; Protection against stupid values in the referer
+ (if (and ref-url (stringp ref-url) (or (string= ref-url "file:nil")
+ (string= ref-url "")))
+ (setq ref-url nil))
+
+ ;; We do not want to expose the referer if the user is paranoid.
+ (if (or (memq url-privacy-level '(low high paranoid))
+ (and (listp url-privacy-level)
+ (memq 'lastloc url-privacy-level)))
+ (setq ref-url nil))
+
+ ;; url-request-extra-headers contains an assoc-list of
+ ;; header/value pairs that we need to put into the request.
+ (setq extra-headers (mapconcat
+ (lambda (x)
+ (concat (car x) ": " (cdr x)))
+ url-request-extra-headers "\r\n"))
+ (if (not (equal extra-headers ""))
+ (setq extra-headers (concat extra-headers "\r\n")))
+
+ ;; This was done with a call to `format'. Concatting parts has
+ ;; the advantage of keeping the parts of each header togther and
+ ;; allows us to elide null lines directly, at the cost of making
+ ;; the layout less clear.
+ (setq request
+ (concat
+ ;; The request
+ (or url-request-method "GET") " " real-fname " HTTP/" url-http-version "\r\n"
+ ;; Version of MIME we speak
+ "MIME-Version: 1.0\r\n"
+ ;; (maybe) Try to keep the connection open
+ "Connection: " (if (or proxy-obj
+ (not url-http-attempt-keepalives))
+ "close" "keep-alive") "\r\n"
+ ;; HTTP extensions we support
+ (if url-extensions-header
+ (format
+ "Extension: %s\r\n" url-extensions-header))
+ ;; Who we want to talk to
+ (if (/= (url-port (or proxy-obj url))
+ (url-scheme-get-property
+ (url-type (or proxy-obj url)) 'default-port))
+ (format
+ "Host: %s:%d\r\n" host (url-port (or proxy-obj url)))
+ (format "Host: %s\r\n" host))
+ ;; Who its from
+ (if url-personal-mail-address
+ (concat
+ "From: " url-personal-mail-address "\r\n"))
+ ;; Encodings we understand
+ (if url-mime-encoding-string
+ (concat
+ "Accept-encoding: " url-mime-encoding-string "\r\n"))
+ (if url-mime-charset-string
+ (concat
+ "Accept-charset: " url-mime-charset-string "\r\n"))
+ ;; Languages we understand
+ (if url-mime-language-string
+ (concat
+ "Accept-language: " url-mime-language-string "\r\n"))
+ ;; Types we understand
+ "Accept: " (or url-mime-accept-string "*/*") "\r\n"
+ ;; User agent
+ (url-http-user-agent-string)
+ ;; Proxy Authorization
+ proxy-auth
+ ;; Authorization
+ auth
+ ;; Cookies
+ (url-cookie-generate-header-lines host real-fname
+ (equal "https" (url-type url)))
+ ;; If-modified-since
+ (if (and (not no-cache)
+ (member url-request-method '("GET" nil)))
+ (let ((tm (url-is-cached (or proxy-obj url))))
+ (if tm
+ (concat "If-modified-since: "
+ (url-get-normalized-date tm) "\r\n"))))
+ ;; Whence we came
+ (if ref-url (concat
+ "Referer: " ref-url "\r\n"))
+ extra-headers
+ ;; Any data
+ (if url-request-data
+ (concat
+ "Content-length: " (number-to-string
+ (length url-request-data))
+ "\r\n\r\n"
+ url-request-data))
+ ;; End request
+ "\r\n"))
+ (url-http-debug "Request is: \n%s" request)
+ request))
+
+;; Parsing routines
+(defun url-http-clean-headers ()
+ "Remove trailing \r from header lines.
+This allows us to use `mail-fetch-field', etc."
+ (declare (special url-http-end-of-headers))
+ (goto-char (point-min))
+ (while (re-search-forward "\r$" url-http-end-of-headers t)
+ (replace-match "")))
+
+(defun url-http-handle-authentication (proxy)
+ (declare (special status success url-http-method url-http-data
+ url-callback-function url-callback-arguments))
+ (url-http-debug "Handling %s authentication" (if proxy "proxy" "normal"))
+ (let ((auth (or (mail-fetch-field (if proxy "proxy-authenticate" "www-authenticate"))
+ "basic"))
+ (type nil)
+ (url (url-recreate-url url-current-object))
+ (url-basic-auth-storage 'url-http-real-basic-auth-storage)
+ )
+
+ ;; Cheating, but who cares? :)
+ (if proxy
+ (setq url-basic-auth-storage 'url-http-proxy-basic-auth-storage))
+
+ (setq auth (url-eat-trailing-space (url-strip-leading-spaces auth)))
+ (if (string-match "[ \t]" auth)
+ (setq type (downcase (substring auth 0 (match-beginning 0))))
+ (setq type (downcase auth)))
+
+ (if (not (url-auth-registered type))
+ (progn
+ (widen)
+ (goto-char (point-max))
+ (insert "<hr>Sorry, but I do not know how to handle " type
+ " authentication. If you'd like to write it,"
+ " send it to " url-bug-address ".<hr>")
+ (setq status t))
+ (let* ((args auth)
+ (ctr (1- (length args)))
+ auth)
+ (while (/= 0 ctr)
+ (if (char-equal ?, (aref args ctr))
+ (aset args ctr ?\;))
+ (setq ctr (1- ctr)))
+ (setq args (url-parse-args args)
+ auth (url-get-authentication url (cdr-safe (assoc "realm" args))
+ type t args))
+ (if (not auth)
+ (setq success t)
+ (push (cons (if proxy "Proxy-Authorization" "Authorization") auth)
+ url-http-extra-headers)
+ (let ((url-request-method url-http-method)
+ (url-request-data url-http-data)
+ (url-request-extra-headers url-http-extra-headers))
+ (url-retrieve url url-callback-function url-callback-arguments))))
+ (kill-buffer (current-buffer)))))
+
+(defun url-http-parse-response ()
+ "Parse just the response code."
+ (declare (special url-http-end-of-headers url-http-response-status))
+ (if (not url-http-end-of-headers)
+ (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name)))
+ (url-http-debug "url-http-parse-response called in (%s)" (buffer-name))
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n") ; Skip any blank crap
+ (skip-chars-forward "HTTP/") ; Skip HTTP Version
+ (read (current-buffer))
+ (setq url-http-response-status (read (current-buffer))))
+
+(defun url-http-handle-cookies ()
+ "Handle all set-cookie / set-cookie2 headers in an HTTP response.
+The buffer must already be narrowed to the headers, so mail-fetch-field will
+work correctly."
+ (let ((cookies (mail-fetch-field "Set-Cookie" nil nil t))
+ (cookies2 (mail-fetch-field "Set-Cookie2" nil nil t)))
+ (and cookies (url-http-debug "Found %d Set-Cookie headers" (length cookies)))
+ (and cookies2 (url-http-debug "Found %d Set-Cookie2 headers" (length cookies2)))
+ (while cookies
+ (url-cookie-handle-set-cookie (pop cookies)))
+;;; (while cookies2
+;;; (url-cookie-handle-set-cookie2 (pop cookies)))
+ )
+ )
+
+(defun url-http-parse-headers ()
+ "Parse and handle HTTP specific headers.
+Return t if and only if the current buffer is still active and
+should be shown to the user."
+ ;; The comments after each status code handled are taken from RFC
+ ;; 2616 (HTTP/1.1)
+ (declare (special url-http-end-of-headers url-http-response-status
+ url-http-method url-http-data url-http-process
+ url-callback-function url-callback-arguments))
+
+ (url-http-mark-connection-as-free (url-host url-current-object)
+ (url-port url-current-object)
+ url-http-process)
+
+ (if (or (not (boundp 'url-http-end-of-headers))
+ (not url-http-end-of-headers))
+ (error "Trying to parse headers in odd buffer: %s" (buffer-name)))
+ (goto-char (point-min))
+ (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name))
+ (url-http-parse-response)
+ (mail-narrow-to-head)
+ ;;(narrow-to-region (point-min) url-http-end-of-headers)
+ (let ((class nil)
+ (success nil))
+ (setq class (/ url-http-response-status 100))
+ (url-http-debug "Parsed HTTP headers: class=%d status=%d" class url-http-response-status)
+ (url-http-handle-cookies)
+
+ (case class
+ ;; Classes of response codes
+ ;;
+ ;; 5xx = Server Error
+ ;; 4xx = Client Error
+ ;; 3xx = Redirection
+ ;; 2xx = Successful
+ ;; 1xx = Informational
+ (1 ; Information messages
+ ;; 100 = Continue with request
+ ;; 101 = Switching protocols
+ ;; 102 = Processing (Added by DAV)
+ (url-mark-buffer-as-dead (current-buffer))
+ (error "HTTP responses in class 1xx not supported (%d)" url-http-response-status))
+ (2 ; Success
+ ;; 200 Ok
+ ;; 201 Created
+ ;; 202 Accepted
+ ;; 203 Non-authoritative information
+ ;; 204 No content
+ ;; 205 Reset content
+ ;; 206 Partial content
+ ;; 207 Multi-status (Added by DAV)
+ (case url-http-response-status
+ ((204 205)
+ ;; No new data, just stay at the same document
+ (url-mark-buffer-as-dead (current-buffer))
+ (setq success t))
+ (otherwise
+ ;; Generic success for all others. Store in the cache, and
+ ;; mark it as successful.
+ (widen)
+ (if (equal url-http-method "GET")
+ (url-store-in-cache (current-buffer)))
+ (setq success t))))
+ (3 ; Redirection
+ ;; 300 Multiple choices
+ ;; 301 Moved permanently
+ ;; 302 Found
+ ;; 303 See other
+ ;; 304 Not modified
+ ;; 305 Use proxy
+ ;; 307 Temporary redirect
+ (let ((redirect-uri (or (mail-fetch-field "Location")
+ (mail-fetch-field "URI"))))
+ (case url-http-response-status
+ (300
+ ;; Quoth the spec (section 10.3.1)
+ ;; -------------------------------
+ ;; The requested resource corresponds to any one of a set of
+ ;; representations, each with its own specific location and
+ ;; agent-driven negotiation information is being provided so
+ ;; that the user can select a preferred representation and
+ ;; redirect its request to that location.
+ ;; [...]
+ ;; If the server has a preferred choice of representation, it
+ ;; SHOULD include the specific URI for that representation in
+ ;; the Location field; user agents MAY use the Location field
+ ;; value for automatic redirection.
+ ;; -------------------------------
+ ;; We do not support agent-driven negotiation, so we just
+ ;; redirect to the preferred URI if one is provided.
+ nil)
+ ((301 302 307)
+ ;; If the 301|302 status code is received in response to a
+ ;; request other than GET or HEAD, the user agent MUST NOT
+ ;; automatically redirect the request unless it can be
+ ;; confirmed by the user, since this might change the
+ ;; conditions under which the request was issued.
+ (if (member url-http-method '("HEAD" "GET"))
+ ;; Automatic redirection is ok
+ nil
+ ;; It is just too big of a pain in the ass to get this
+ ;; prompt all the time. We will just silently lose our
+ ;; data and convert to a GET method.
+ (url-http-debug "Converting `%s' request to `GET' because of REDIRECT(%d)"
+ url-http-method url-http-response-status)
+ (setq url-http-method "GET"
+ url-request-data nil)))
+ (303
+ ;; The response to the request can be found under a different
+ ;; URI and SHOULD be retrieved using a GET method on that
+ ;; resource.
+ (setq url-http-method "GET"
+ url-http-data nil))
+ (304
+ ;; The 304 response MUST NOT contain a message-body.
+ (url-http-debug "Extracting document from cache... (%s)"
+ (url-cache-create-filename (url-view-url t)))
+ (url-cache-extract (url-cache-create-filename (url-view-url t)))
+ (setq redirect-uri nil
+ success t))
+ (305
+ ;; The requested resource MUST be accessed through the
+ ;; proxy given by the Location field. The Location field
+ ;; gives the URI of the proxy. The recipient is expected
+ ;; to repeat this single request via the proxy. 305
+ ;; responses MUST only be generated by origin servers.
+ (error "Redirection thru a proxy server not supported: %s"
+ redirect-uri))
+ (otherwise
+ ;; Treat everything like '300'
+ nil))
+ (when redirect-uri
+ ;; Clean off any whitespace and/or <...> cruft.
+ (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri)
+ (setq redirect-uri (match-string 1 redirect-uri)))
+ (if (string-match "^<\\(.*\\)>$" redirect-uri)
+ (setq redirect-uri (match-string 1 redirect-uri)))
+
+ ;; Some stupid sites (like sourceforge) send a
+ ;; non-fully-qualified URL (ie: /), which royally confuses
+ ;; the URL library.
+ (if (not (string-match url-nonrelative-link redirect-uri))
+ (setq redirect-uri (url-expand-file-name redirect-uri)))
+ (let ((url-request-method url-http-method)
+ (url-request-data url-http-data)
+ (url-request-extra-headers url-http-extra-headers))
+ (url-retrieve redirect-uri url-callback-function
+ url-callback-arguments)
+ (url-mark-buffer-as-dead (current-buffer))))))
+ (4 ; Client error
+ ;; 400 Bad Request
+ ;; 401 Unauthorized
+ ;; 402 Payment required
+ ;; 403 Forbidden
+ ;; 404 Not found
+ ;; 405 Method not allowed
+ ;; 406 Not acceptable
+ ;; 407 Proxy authentication required
+ ;; 408 Request time-out
+ ;; 409 Conflict
+ ;; 410 Gone
+ ;; 411 Length required
+ ;; 412 Precondition failed
+ ;; 413 Request entity too large
+ ;; 414 Request-URI too large
+ ;; 415 Unsupported media type
+ ;; 416 Requested range not satisfiable
+ ;; 417 Expectation failed
+ ;; 422 Unprocessable Entity (Added by DAV)
+ ;; 423 Locked
+ ;; 424 Failed Dependency
+ (case url-http-response-status
+ (401
+ ;; The request requires user authentication. The response
+ ;; MUST include a WWW-Authenticate header field containing a
+ ;; challenge applicable to the requested resource. The
+ ;; client MAY repeat the request with a suitable
+ ;; Authorization header field.
+ (url-http-handle-authentication nil))
+ (402
+ ;; This code is reserved for future use
+ (url-mark-buffer-as-dead (current-buffer))
+ (error "Somebody wants you to give them money"))
+ (403
+ ;; The server understood the request, but is refusing to
+ ;; fulfill it. Authorization will not help and the request
+ ;; SHOULD NOT be repeated.
+ (setq success t))
+ (404
+ ;; Not found
+ (setq success t))
+ (405
+ ;; The method specified in the Request-Line is not allowed
+ ;; for the resource identified by the Request-URI. The
+ ;; response MUST include an Allow header containing a list of
+ ;; valid methods for the requested resource.
+ (setq success t))
+ (406
+ ;; The resource identified by the request is only capable of
+ ;; generating response entities which have content
+ ;; characteristics nota cceptable according to the accept
+ ;; headers sent in the request.
+ (setq success t))
+ (407
+ ;; This code is similar to 401 (Unauthorized), but indicates
+ ;; that the client must first authenticate itself with the
+ ;; proxy. The proxy MUST return a Proxy-Authenticate header
+ ;; field containing a challenge applicable to the proxy for
+ ;; the requested resource.
+ (url-http-handle-authentication t))
+ (408
+ ;; The client did not produce a request within the time that
+ ;; the server was prepared to wait. The client MAY repeat
+ ;; the request without modifications at any later time.
+ (setq success t))
+ (409
+ ;; The request could not be completed due to a conflict with
+ ;; the current state of the resource. This code is only
+ ;; allowed in situations where it is expected that the user
+ ;; mioght be able to resolve the conflict and resubmit the
+ ;; request. The response body SHOULD include enough
+ ;; information for the user to recognize the source of the
+ ;; conflict.
+ (setq success t))
+ (410
+ ;; The requested resource is no longer available at the
+ ;; server and no forwarding address is known.
+ (setq success t))
+ (411
+ ;; The server refuses to accept the request without a defined
+ ;; Content-Length. The client MAY repeat the request if it
+ ;; adds a valid Content-Length header field containing the
+ ;; length of the message-body in the request message.
+ ;;
+ ;; NOTE - this will never happen because
+ ;; `url-http-create-request' automatically calculates the
+ ;; content-length.
+ (setq success t))
+ (412
+ ;; The precondition given in one or more of the
+ ;; request-header fields evaluated to false when it was
+ ;; tested on the server.
+ (setq success t))
+ ((413 414)
+ ;; The server is refusing to process a request because the
+ ;; request entity|URI is larger than the server is willing or
+ ;; able to process.
+ (setq success t))
+ (415
+ ;; The server is refusing to service the request because the
+ ;; entity of the request is in a format not supported by the
+ ;; requested resource for the requested method.
+ (setq success t))
+ (416
+ ;; A server SHOULD return a response with this status code if
+ ;; a request included a Range request-header field, and none
+ ;; of the range-specifier values in this field overlap the
+ ;; current extent of the selected resource, and the request
+ ;; did not include an If-Range request-header field.
+ (setq success t))
+ (417
+ ;; The expectation given in an Expect request-header field
+ ;; could not be met by this server, or, if the server is a
+ ;; proxy, the server has unambiguous evidence that the
+ ;; request could not be met by the next-hop server.
+ (setq success t))
+ (otherwise
+ ;; The request could not be understood by the server due to
+ ;; malformed syntax. The client SHOULD NOT repeat the
+ ;; request without modifications.
+ (setq success t))))
+ (5
+ ;; 500 Internal server error
+ ;; 501 Not implemented
+ ;; 502 Bad gateway
+ ;; 503 Service unavailable
+ ;; 504 Gateway time-out
+ ;; 505 HTTP version not supported
+ ;; 507 Insufficient storage
+ (setq success t)
+ (case url-http-response-status
+ (501
+ ;; The server does not support the functionality required to
+ ;; fulfill the request.
+ nil)
+ (502
+ ;; The server, while acting as a gateway or proxy, received
+ ;; an invalid response from the upstream server it accessed
+ ;; in attempting to fulfill the request.
+ nil)
+ (503
+ ;; The server is currently unable to handle the request due
+ ;; to a temporary overloading or maintenance of the server.
+ ;; The implication is that this is a temporary condition
+ ;; which will be alleviated after some delay. If known, the
+ ;; length of the delay MAY be indicated in a Retry-After
+ ;; header. If no Retry-After is given, the client SHOULD
+ ;; handle the response as it would for a 500 response.
+ nil)
+ (504
+ ;; The server, while acting as a gateway or proxy, did not
+ ;; receive a timely response from the upstream server
+ ;; specified by the URI (e.g. HTTP, FTP, LDAP) or some other
+ ;; auxiliary server (e.g. DNS) it needed to access in
+ ;; attempting to complete the request.
+ nil)
+ (505
+ ;; The server does not support, or refuses to support, the
+ ;; HTTP protocol version that was used in the request
+ ;; message.
+ nil)
+ (507 ; DAV
+ ;; The method could not be performed on the resource
+ ;; because the server is unable to store the representation
+ ;; needed to successfully complete the request. This
+ ;; condition is considered to be temporary. If the request
+ ;; which received this status code was the result of a user
+ ;; action, the request MUST NOT be repeated until it is
+ ;; requested by a separate user action.
+ nil)))
+ (otherwise
+ (error "Unknown class of HTTP response code: %d (%d)"
+ class url-http-response-status)))
+ (if (not success)
+ (url-mark-buffer-as-dead (current-buffer)))
+ (url-http-debug "Finished parsing HTTP headers: %S" success)
+ (widen)
+ success))
+
+;; Miscellaneous
+(defun url-http-activate-callback ()
+ "Activate callback specified when this buffer was created."
+ (declare (special url-http-process
+ url-callback-function
+ url-callback-arguments))
+ (url-http-mark-connection-as-free (url-host url-current-object)
+ (url-port url-current-object)
+ url-http-process)
+ (url-http-debug "Activating callback in buffer (%s)" (buffer-name))
+ (apply url-callback-function url-callback-arguments))
+
+;; )
+
+;; These unfortunately cannot be macros... please ignore them!
+(defun url-http-idle-sentinel (proc why)
+ "Remove this (now defunct) process PROC from the list of open connections."
+ (maphash (lambda (key val)
+ (if (memq proc val)
+ (puthash key (delq proc val) url-http-open-connections)))
+ url-http-open-connections))
+
+(defun url-http-end-of-document-sentinel (proc why)
+ ;; Sentinel used for old HTTP/0.9 or connections we know are going
+ ;; to die as the 'end of document' notifier.
+ (url-http-debug "url-http-end-of-document-sentinel in buffer (%s)"
+ (process-buffer proc))
+ (url-http-idle-sentinel proc why)
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (goto-char (point-min))
+ (if (not (looking-at "HTTP/"))
+ ;; HTTP/0.9 just gets passed back no matter what
+ (url-http-activate-callback)
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))))
+
+(defun url-http-simple-after-change-function (st nd length)
+ ;; Function used when we do NOT know how long the document is going to be
+ ;; Just _very_ simple 'downloaded %d' type of info.
+ (declare (special url-http-end-of-headers))
+ (url-lazy-message "Reading %s..." (url-pretty-length nd)))
+
+(defun url-http-content-length-after-change-function (st nd length)
+ "Function used when we DO know how long the document is going to be.
+More sophisticated percentage downloaded, etc.
+Also does minimal parsing of HTTP headers and will actually cause
+the callback to be triggered."
+ (declare (special url-current-object
+ url-http-end-of-headers
+ url-http-content-length
+ url-http-content-type
+ url-http-process))
+ (if url-http-content-type
+ (url-display-percentage
+ "Reading [%s]... %s of %s (%d%%)"
+ (url-percentage (- nd url-http-end-of-headers)
+ url-http-content-length)
+ url-http-content-type
+ (url-pretty-length (- nd url-http-end-of-headers))
+ (url-pretty-length url-http-content-length)
+ (url-percentage (- nd url-http-end-of-headers)
+ url-http-content-length))
+ (url-display-percentage
+ "Reading... %s of %s (%d%%)"
+ (url-percentage (- nd url-http-end-of-headers)
+ url-http-content-length)
+ (url-pretty-length (- nd url-http-end-of-headers))
+ (url-pretty-length url-http-content-length)
+ (url-percentage (- nd url-http-end-of-headers)
+ url-http-content-length)))
+
+ (if (> (- nd url-http-end-of-headers) url-http-content-length)
+ (progn
+ ;; Found the end of the document! Wheee!
+ (url-display-percentage nil nil)
+ (message "Reading... done.")
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))))
+
+(defun url-http-chunked-encoding-after-change-function (st nd length)
+ "Function used when dealing with 'chunked' encoding.
+Cannot give a sophisticated percentage, but we need a different
+function to look for the special 0-length chunk that signifies
+the end of the document."
+ (declare (special url-current-object
+ url-http-end-of-headers
+ url-http-content-type
+ url-http-chunked-length
+ url-http-chunked-counter
+ url-http-process url-http-chunked-start))
+ (save-excursion
+ (goto-char st)
+ (let ((read-next-chunk t)
+ (case-fold-search t)
+ (regexp nil)
+ (no-initial-crlf nil))
+ ;; We need to loop thru looking for more chunks even within
+ ;; one after-change-function call.
+ (while read-next-chunk
+ (setq no-initial-crlf (= 0 url-http-chunked-counter))
+ (if url-http-content-type
+ (url-display-percentage nil
+ "Reading [%s]... chunk #%d"
+ url-http-content-type url-http-chunked-counter)
+ (url-display-percentage nil
+ "Reading... chunk #%d"
+ url-http-chunked-counter))
+ (url-http-debug "Reading chunk %d (%d %d %d)"
+ url-http-chunked-counter st nd length)
+ (setq regexp (if no-initial-crlf
+ "\\([0-9a-z]+\\).*\r?\n"
+ "\r?\n\\([0-9a-z]+\\).*\r?\n"))
+
+ (if url-http-chunked-start
+ ;; We know how long the chunk is supposed to be, skip over
+ ;; leading crap if possible.
+ (if (> nd (+ url-http-chunked-start url-http-chunked-length))
+ (progn
+ (url-http-debug "Got to the end of chunk #%d!"
+ url-http-chunked-counter)
+ (goto-char (+ url-http-chunked-start
+ url-http-chunked-length)))
+ (url-http-debug "Still need %d bytes to hit end of chunk"
+ (- (+ url-http-chunked-start
+ url-http-chunked-length)
+ nd))
+ (setq read-next-chunk nil)))
+ (if (not read-next-chunk)
+ (url-http-debug "Still spinning for next chunk...")
+ (if no-initial-crlf (skip-chars-forward "\r\n"))
+ (if (not (looking-at regexp))
+ (progn
+ ;; Must not have received the entirety of the chunk header,
+ ;; need to spin some more.
+ (url-http-debug "Did not see start of chunk @ %d!" (point))
+ (setq read-next-chunk nil))
+ (add-text-properties (match-beginning 0) (match-end 0)
+ (list 'start-open t
+ 'end-open t
+ 'chunked-encoding t
+ 'face (if (featurep 'xemacs)
+ 'text-cursor
+ 'cursor)
+ 'invisible t))
+ (setq url-http-chunked-length (string-to-int (buffer-substring
+ (match-beginning 1)
+ (match-end 1))
+ 16)
+ url-http-chunked-counter (1+ url-http-chunked-counter)
+ url-http-chunked-start (set-marker
+ (or url-http-chunked-start
+ (make-marker))
+ (match-end 0)))
+; (if (not url-http-debug)
+ (delete-region (match-beginning 0) (match-end 0));)
+ (url-http-debug "Saw start of chunk %d (length=%d, start=%d"
+ url-http-chunked-counter url-http-chunked-length
+ (marker-position url-http-chunked-start))
+ (if (= 0 url-http-chunked-length)
+ (progn
+ ;; Found the end of the document! Wheee!
+ (url-http-debug "Saw end of stream chunk!")
+ (setq read-next-chunk nil)
+ (url-display-percentage nil nil)
+ (goto-char (match-end 1))
+ (if (re-search-forward "^\r*$" nil t)
+ (message "Saw end of trailers..."))
+ (if (url-http-parse-headers)
+ (url-http-activate-callback))))))))))
+
+(defun url-http-wait-for-headers-change-function (st nd length)
+ ;; This will wait for the headers to arrive and then splice in the
+ ;; next appropriate after-change-function, etc.
+ (declare (special url-current-object
+ url-http-end-of-headers
+ url-http-content-type
+ url-http-content-length
+ url-http-transfer-encoding
+ url-callback-function
+ url-callback-arguments
+ url-http-process
+ url-http-method
+ url-http-after-change-function
+ url-http-response-status))
+ (url-http-debug "url-http-wait-for-headers-change-function (%s)"
+ (buffer-name))
+ (if (not (bobp))
+ (let ((end-of-headers nil)
+ (old-http nil)
+ (content-length nil))
+ (goto-char (point-min))
+ (if (not (looking-at "^HTTP/[1-9]\\.[0-9]"))
+ ;; Not HTTP/x.y data, must be 0.9
+ ;; God, I wish this could die.
+ (setq end-of-headers t
+ url-http-end-of-headers 0
+ old-http t)
+ (if (re-search-forward "^\r*$" nil t)
+ ;; Saw the end of the headers
+ (progn
+ (url-http-debug "Saw end of headers... (%s)" (buffer-name))
+ (setq url-http-end-of-headers (set-marker (make-marker)
+ (point))
+ end-of-headers t)
+ (url-http-clean-headers))))
+
+ (if (not end-of-headers)
+ ;; Haven't seen the end of the headers yet, need to wait
+ ;; for more data to arrive.
+ nil
+ (if old-http
+ (message "HTTP/0.9 How I hate thee!")
+ (progn
+ (url-http-parse-response)
+ (mail-narrow-to-head)
+ ;;(narrow-to-region (point-min) url-http-end-of-headers)
+ (setq url-http-transfer-encoding (mail-fetch-field
+ "transfer-encoding")
+ url-http-content-type (mail-fetch-field "content-type"))
+ (if (mail-fetch-field "content-length")
+ (setq url-http-content-length
+ (string-to-int (mail-fetch-field "content-length"))))
+ (widen)))
+ (if url-http-transfer-encoding
+ (setq url-http-transfer-encoding
+ (downcase url-http-transfer-encoding)))
+
+ (cond
+ ((or (= url-http-response-status 204)
+ (= url-http-response-status 205))
+ (url-http-debug "%d response must have headers only (%s)."
+ url-http-response-status (buffer-name))
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((string= "HEAD" url-http-method)
+ ;; A HEAD request is _ALWAYS_ terminated by the header
+ ;; information, regardless of any entity headers,
+ ;; according to section 4.4 of the HTTP/1.1 draft.
+ (url-http-debug "HEAD request must have headers only (%s)."
+ (buffer-name))
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((string= "CONNECT" url-http-method)
+ ;; A CONNECT request is finished, but we cannot stick this
+ ;; back on the free connectin list
+ (url-http-debug "CONNECT request must have headers only.")
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((equal url-http-response-status 304)
+ ;; Only allowed to have a header section. We have to handle
+ ;; this here instead of in url-http-parse-headers because if
+ ;; you have a cached copy of something without a known
+ ;; content-length, and try to retrieve it from the cache, we'd
+ ;; fall into the 'being dumb' section and wait for the
+ ;; connection to terminate, which means we'd wait for 10
+ ;; seconds for the keep-alives to time out on some servers.
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))
+ (old-http
+ ;; HTTP/0.9 always signaled end-of-connection by closing the
+ ;; connection.
+ (url-http-debug
+ "Saw HTTP/0.9 response, connection closed means end of document.")
+ (setq url-http-after-change-function
+ 'url-http-simple-after-change-function))
+ ((equal url-http-transfer-encoding "chunked")
+ (url-http-debug "Saw chunked encoding.")
+ (setq url-http-after-change-function
+ 'url-http-chunked-encoding-after-change-function)
+ (if (> nd url-http-end-of-headers)
+ (progn
+ (url-http-debug
+ "Calling initial chunked-encoding for extra data at end of headers")
+ (url-http-chunked-encoding-after-change-function
+ (marker-position url-http-end-of-headers) nd
+ (- nd url-http-end-of-headers)))))
+ ((integerp url-http-content-length)
+ (url-http-debug
+ "Got a content-length, being smart about document end.")
+ (setq url-http-after-change-function
+ 'url-http-content-length-after-change-function)
+ (cond
+ ((= 0 url-http-content-length)
+ ;; We got a NULL body! Activate the callback
+ ;; immediately!
+ (url-http-debug
+ "Got 0-length content-length, activating callback immediately.")
+ (if (url-http-parse-headers)
+ (url-http-activate-callback)))
+ ((> nd url-http-end-of-headers)
+ ;; Have some leftover data
+ (url-http-debug "Calling initial content-length for extra data at end of headers")
+ (url-http-content-length-after-change-function
+ (marker-position url-http-end-of-headers)
+ nd
+ (- nd url-http-end-of-headers)))
+ (t
+ nil)))
+ (t
+ (url-http-debug "No content-length, being dumb.")
+ (setq url-http-after-change-function
+ 'url-http-simple-after-change-function)))))
+ ;; We are still at the beginning of the buffer... must just be
+ ;; waiting for a response.
+ (url-http-debug "Spinning waiting for headers..."))
+ (goto-char (point-max)))
+
+;;;###autoload
+(defun url-http (url callback cbargs)
+ "Retrieve URL via HTTP asynchronously.
+URL must be a parsed URL. See `url-generic-parse-url' for details.
+When retrieval is completed, the function CALLBACK is executed with
+CBARGS as the arguments."
+ (check-type url vector "Need a pre-parsed URL.")
+ (declare (special url-current-object
+ url-http-end-of-headers
+ url-http-content-type
+ url-http-content-length
+ url-http-transfer-encoding
+ url-http-after-change-function
+ url-callback-function
+ url-callback-arguments
+ url-http-method
+ url-http-extra-headers
+ url-http-data
+ url-http-chunked-length
+ url-http-chunked-start
+ url-http-chunked-counter
+ url-http-process))
+ (let ((connection (url-http-find-free-connection (url-host url)
+ (url-port url)))
+ (buffer (generate-new-buffer (format " *http %s:%d*"
+ (url-host url)
+ (url-port url)))))
+ (if (not connection)
+ ;; Failed to open the connection for some reason
+ (progn
+ (kill-buffer buffer)
+ (setq buffer nil)
+ (error "Could not create connection to %s:%d" (url-host url)
+ (url-port url)))
+ (save-excursion
+ (set-buffer buffer)
+ (mm-disable-multibyte)
+ (setq url-current-object url
+ mode-line-format "%b [%s]")
+
+ (dolist (var '(url-http-end-of-headers
+ url-http-content-type
+ url-http-content-length
+ url-http-transfer-encoding
+ url-http-after-change-function
+ url-http-response-status
+ url-http-chunked-length
+ url-http-chunked-counter
+ url-http-chunked-start
+ url-callback-function
+ url-callback-arguments
+ url-http-process
+ url-http-method
+ url-http-extra-headers
+ url-http-data))
+ (set (make-local-variable var) nil))
+
+ (setq url-http-method (or url-request-method "GET")
+ url-http-extra-headers url-request-extra-headers
+ url-http-data url-request-data
+ url-http-process connection
+ url-http-chunked-length nil
+ url-http-chunked-start nil
+ url-http-chunked-counter 0
+ url-callback-function callback
+ url-callback-arguments cbargs
+ url-http-after-change-function 'url-http-wait-for-headers-change-function)
+
+ (set-process-buffer connection buffer)
+ (set-process-sentinel connection 'url-http-end-of-document-sentinel)
+ (set-process-filter connection 'url-http-generic-filter)
+ (process-send-string connection (url-http-create-request url))))
+ buffer))
+
+;; Since Emacs 19/20 does not allow you to change the
+;; `after-change-functions' hook in the midst of running them, we fake
+;; an after change by hooking into the process filter and inserting
+;; the data ourselves. This is slightly less efficient, but there
+;; were tons of weird ways the after-change code was biting us in the
+;; shorts.
+(defun url-http-generic-filter (proc data)
+ ;; Sometimes we get a zero-length data chunk after the process has
+ ;; been changed to 'free', which means it has no buffer associated
+ ;; with it. Do nothing if there is no buffer, or 0 length data.
+ (declare (special url-http-after-change-function))
+ (and (process-buffer proc)
+ (/= (length data) 0)
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (url-http-debug "Calling after change function `%s' for `%S'" url-http-after-change-function proc)
+ (funcall url-http-after-change-function
+ (point-max)
+ (progn
+ (goto-char (point-max))
+ (insert data)
+ (point-max))
+ (length data)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; file-name-handler stuff from here on out
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(if (not (fboundp 'symbol-value-in-buffer))
+ (defun url-http-symbol-value-in-buffer (symbol buffer
+ &optional unbound-value)
+ "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
+ (save-excursion
+ (set-buffer buffer)
+ (if (not (boundp symbol))
+ unbound-value
+ (symbol-value symbol))))
+ (defalias 'url-http-symbol-value-in-buffer 'symbol-value-in-buffer))
+
+(defun url-http-head (url)
+ (let ((url-request-method "HEAD")
+ (url-request-data nil))
+ (url-retrieve-synchronously url)))
+
+;;;###autoload
+(defun url-http-file-exists-p (url)
+ (let ((status nil)
+ (exists nil)
+ (buffer (url-http-head url)))
+ (if (not buffer)
+ (setq exists nil)
+ (setq status (url-http-symbol-value-in-buffer 'url-http-response-status
+ buffer 500)
+ exists (and (>= status 200) (< status 300)))
+ (kill-buffer buffer))
+ exists))
+
+;;;###autoload
+(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
+
+(defun url-http-head-file-attributes (url &optional id-format)
+ (let ((buffer (url-http-head url))
+ (attributes nil))
+ (when buffer
+ (setq attributes (make-list 11 nil))
+ (setf (nth 1 attributes) 1) ; Number of links to file
+ (setf (nth 2 attributes) 0) ; file uid
+ (setf (nth 3 attributes) 0) ; file gid
+ (setf (nth 7 attributes) ; file size
+ (url-http-symbol-value-in-buffer 'url-http-content-length
+ buffer -1))
+ (setf (nth 8 attributes) (eval-when-compile (make-string 10 ?-)))
+ (kill-buffer buffer))
+ attributes))
+
+;;;###autoload
+(defun url-http-file-attributes (url &optional id-format)
+ (if (url-dav-supported-p url)
+ (url-dav-file-attributes url id-format)
+ (url-http-head-file-attributes url id-format)))
+
+;;;###autoload
+(defun url-http-options (url)
+ "Returns a property list describing options available for URL.
+This list is retrieved using the `OPTIONS' HTTP method.
+
+Property list members:
+
+methods
+ A list of symbols specifying what HTTP methods the resource
+ supports.
+
+dav
+ A list of numbers specifying what DAV protocol/schema versions are
+ supported.
+
+dasl
+ A list of supported DASL search types supported (string form)
+
+ranges
+ A list of the units available for use in partial document fetches.
+
+p3p
+ The `Platform For Privacy Protection' description for the resource.
+ Currently this is just the raw header contents. This is likely to
+ change once P3P is formally supported by the URL package or
+ Emacs/W3.
+"
+ (let* ((url-request-method "OPTIONS")
+ (url-request-data nil)
+ (buffer (url-retrieve-synchronously url))
+ (header nil)
+ (options nil))
+ (when (and buffer (= 2 (/ (url-http-symbol-value-in-buffer
+ 'url-http-response-status buffer 0) 100)))
+ ;; Only parse the options if we got a 2xx response code!
+ (save-excursion
+ (save-restriction
+ (save-match-data
+ (set-buffer buffer)
+ (mail-narrow-to-head)
+
+ ;; Figure out what methods are supported.
+ (when (setq header (mail-fetch-field "allow"))
+ (setq options (plist-put
+ options 'methods
+ (mapcar 'intern (split-string header "[ ,]+")))))
+
+ ;; Check for DAV
+ (when (setq header (mail-fetch-field "dav"))
+ (setq options (plist-put
+ options 'dav
+ (delq 0
+ (mapcar 'string-to-number
+ (split-string header "[, ]+"))))))
+
+ ;; Now for DASL
+ (when (setq header (mail-fetch-field "dasl"))
+ (setq options (plist-put
+ options 'dasl
+ (split-string header "[, ]+"))))
+
+ ;; P3P - should get more detailed here. FIXME
+ (when (setq header (mail-fetch-field "p3p"))
+ (setq options (plist-put options 'p3p header)))
+
+ ;; Check for whether they accept byte-range requests.
+ (when (setq header (mail-fetch-field "accept-ranges"))
+ (setq options (plist-put
+ options 'ranges
+ (delq 'none
+ (mapcar 'intern
+ (split-string header "[, ]+"))))))
+ ))))
+ (if buffer (kill-buffer buffer))
+ options))
+
+(provide 'url-http)
+
+;; arch-tag: ba7c59ae-c0f4-4a31-9617-d85f221732ee
+;;; url-http.el ends here
diff --git a/lisp/url/url-https.el b/lisp/url/url-https.el
new file mode 100644
index 00000000000..11b2593ea80
--- /dev/null
+++ b/lisp/url/url-https.el
@@ -0,0 +1,56 @@
+;;; url-https.el --- HTTP over SSL routines
+
+;; Copyright (c) 1999, 2004 Free Software Foundation, Inc.
+
+;; Keywords: comm, data, processes
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'url-gw)
+(require 'url-util)
+(require 'url-parse)
+(require 'url-cookie)
+(require 'url-http)
+
+(defconst url-https-default-port 443 "Default HTTPS port.")
+(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
+(defalias 'url-https-expand-file-name 'url-http-expand-file-name)
+
+(defmacro url-https-create-secure-wrapper (method args)
+ `(defun ,(intern (format (if method "url-https-%s" "url-https") method)) ,args
+ ,(format "HTTPS wrapper around `%s' call." (or method "url-http"))
+ (condition-case ()
+ (require 'ssl)
+ (error
+ (error "HTTPS support could not find `ssl' library")))
+ (let ((url-gateway-method 'ssl))
+ ( ,(intern (format (if method "url-http-%s" "url-http") method)) ,@(remove '&rest (remove '&optional args))))))
+
+(url-https-create-secure-wrapper nil (url callback cbargs))
+(url-https-create-secure-wrapper file-exists-p (url))
+(url-https-create-secure-wrapper file-readable-p (url))
+(url-https-create-secure-wrapper file-attributes (url &optional id-format))
+
+(provide 'url-https)
+
+;; arch-tag: c3645ac5-c248-4d12-ad41-7c4b6f7b6d19
+;;; url-https.el ends here
diff --git a/lisp/url/url-nfs.el b/lisp/url/url-nfs.el
new file mode 100644
index 00000000000..d068341b1c2
--- /dev/null
+++ b/lisp/url/url-nfs.el
@@ -0,0 +1,100 @@
+;;; url-nfs.el --- NFS URL interface
+
+;; Copyright (c) 1996,97,98,1999,2004 Free Software Foundation, Inc.
+;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
+
+;; Keywords: comm, data, processes
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'url-parse)
+(require 'url-file)
+
+(defvar url-nfs-automounter-directory-spec
+ "file:/net/%h%f"
+ "*How to invoke the NFS automounter. Certain % sequences are recognized.
+
+%h -- the hostname of the NFS server
+%n -- the port # of the NFS server
+%u -- the username to use to authenticate
+%p -- the password to use to authenticate
+%f -- the filename on the remote server
+%% -- a literal %
+
+Each can be used any number of times.")
+
+(defun url-nfs-unescape (format host port user pass file)
+ (save-excursion
+ (set-buffer (get-buffer-create " *nfs-parse*"))
+ (erase-buffer)
+ (insert format)
+ (goto-char (point-min))
+ (while (re-search-forward "%\\(.\\)" nil t)
+ (let ((escape (aref (match-string 1) 0)))
+ (replace-match "" t t)
+ (case escape
+ (?% (insert "%"))
+ (?h (insert host))
+ (?n (insert (or port "")))
+ (?u (insert (or user "")))
+ (?p (insert (or pass "")))
+ (?f (insert (or file "/"))))))
+ (buffer-string)))
+
+(defun url-nfs-build-filename (url)
+ (let* ((host (url-host url))
+ (port (string-to-int (url-port url)))
+ (pass (url-password url))
+ (user (url-user url))
+ (file (url-filename url)))
+ (url-generic-parse-url
+ (url-nfs-unescape url-nfs-automounter-directory-spec
+ host port user pass file))))
+
+(defun url-nfs (url callback cbargs)
+ (url-file (url-nfs-build-filename url) callback cbargs))
+
+(defmacro url-nfs-create-wrapper (method args)
+ `(defun ,(intern (format "url-nfs-%s" method)) ,args
+ ,(format "NFS URL wrapper around `%s' call." method)
+ (setq url (url-nfs-build-filename url))
+ (and url (,(intern (format "url-file-%s" method))
+ ,@(remove '&rest (remove '&optional args))))))
+
+(url-nfs-create-wrapper file-exists-p (url))
+(url-nfs-create-wrapper file-attributes (url &optional id-format))
+(url-nfs-create-wrapper file-symlink-p (url))
+(url-nfs-create-wrapper file-readable-p (url))
+(url-nfs-create-wrapper file-writable-p (url))
+(url-nfs-create-wrapper file-executable-p (url))
+(if (featurep 'xemacs)
+ (progn
+ (url-nfs-create-wrapper directory-files (url &optional full match nosort files-only))
+ (url-nfs-create-wrapper file-truename (url &optional default)))
+ (url-nfs-create-wrapper directory-files (url &optional full match nosort))
+ (url-nfs-create-wrapper file-truename (url &optional counter prev-dirs)))
+
+(provide 'url-nfs)
+
+;; arch-tag: cdf9c9ba-b7d2-4c29-8b48-7ae9bbc0d437
+;;; url-nfs.el ends here
diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el
new file mode 100644
index 00000000000..d4a3733eab5
--- /dev/null
+++ b/lisp/url/url-util.el
@@ -0,0 +1,508 @@
+;;; url-util.el --- Miscellaneous helper routines for URL library
+
+;; Copyright (c) 1996,97,98,99,2001,2004 Free Software Foundation, Inc.
+;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
+
+;; Author: Bill Perry <wmperry@gnu.org>
+;; Keywords: comm, data, processes
+
+;; 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 2, 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., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'url-parse)
+(autoload 'timezone-parse-date "timezone")
+(autoload 'timezone-make-date-arpa-standard "timezone")
+(autoload 'mail-header-extract "mailheader")
+
+(defvar url-parse-args-syntax-table
+ (copy-syntax-table emacs-lisp-mode-syntax-table)
+ "A syntax table for parsing sgml attributes.")
+
+(modify-syntax-entry ?' "\"" url-parse-args-syntax-table)
+(modify-syntax-entry ?` "\"" url-parse-args-syntax-table)
+(modify-syntax-entry ?{ "(" url-parse-args-syntax-table)
+(modify-syntax-entry ?} ")" url-parse-args-syntax-table)
+
+;;;###autoload
+(defcustom url-debug nil
+ "*What types of debug messages from the URL library to show.
+Debug messages are logged to the *URL-DEBUG* buffer.
+
+If t, all messages will be logged.
+If a number, all messages will be logged, as well shown via `message'.
+If a list, it is a list of the types of messages to be logged."
+ :type '(choice (const :tag "none" nil)
+ (const :tag "all" t)
+ (checklist :tag "custom"
+ (const :tag "HTTP" :value http)
+ (const :tag "DAV" :value dav)
+ (const :tag "General" :value retrieval)
+ (const :tag "Filename handlers" :value handlers)
+ (symbol :tag "Other")))
+ :group 'url-hairy)
+
+;;;###autoload
+(defun url-debug (tag &rest args)
+ (if quit-flag
+ (error "Interrupted!"))
+ (if (or (eq url-debug t)
+ (numberp url-debug)
+ (and (listp url-debug) (memq tag url-debug)))
+ (with-current-buffer (get-buffer-create "*URL-DEBUG*")
+ (goto-char (point-max))
+ (insert (symbol-name tag) " -> " (apply 'format args) "\n")
+ (if (numberp url-debug)
+ (apply 'message args)))))
+
+;;;###autoload
+(defun url-parse-args (str &optional nodowncase)
+ ;; Return an assoc list of attribute/value pairs from an RFC822-type string
+ (let (
+ name ; From name=
+ value ; its value
+ results ; Assoc list of results
+ name-pos ; Start of XXXX= position
+ val-pos ; Start of value position
+ st
+ nd
+ )
+ (save-excursion
+ (save-restriction
+ (set-buffer (get-buffer-create " *urlparse-temp*"))
+ (set-syntax-table url-parse-args-syntax-table)
+ (erase-buffer)
+ (insert str)
+ (setq st (point-min)
+ nd (point-max))
+ (set-syntax-table url-parse-args-syntax-table)
+ (narrow-to-region st nd)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (skip-chars-forward "; \n\t")
+ (setq name-pos (point))
+ (skip-chars-forward "^ \n\t=;")
+ (if (not nodowncase)
+ (downcase-region name-pos (point)))
+ (setq name (buffer-substring name-pos (point)))
+ (skip-chars-forward " \t\n")
+ (if (/= (or (char-after (point)) 0) ?=) ; There is no value
+ (setq value nil)
+ (skip-chars-forward " \t\n=")
+ (setq val-pos (point)
+ value
+ (cond
+ ((or (= (or (char-after val-pos) 0) ?\")
+ (= (or (char-after val-pos) 0) ?'))
+ (buffer-substring (1+ val-pos)
+ (condition-case ()
+ (prog2
+ (forward-sexp 1)
+ (1- (point))
+ (skip-chars-forward "\""))
+ (error
+ (skip-chars-forward "^ \t\n")
+ (point)))))
+ (t
+ (buffer-substring val-pos
+ (progn
+ (skip-chars-forward "^;")
+ (skip-chars-backward " \t")
+ (point)))))))
+ (setq results (cons (cons name value) results))
+ (skip-chars-forward "; \n\t"))
+ results))))
+
+;;;###autoload
+(defun url-insert-entities-in-string (string)
+ "Convert HTML markup-start characters to entity references in STRING.
+Also replaces the \" character, so that the result may be safely used as
+ an attribute value in a tag. Returns a new string with the result of the
+ conversion. Replaces these characters as follows:
+ & ==> &amp;
+ < ==> &lt;
+ > ==> &gt;
+ \" ==> &quot;"
+ (if (string-match "[&<>\"]" string)
+ (save-excursion
+ (set-buffer (get-buffer-create " *entity*"))
+ (erase-buffer)
+ (buffer-disable-undo (current-buffer))
+ (insert string)
+ (goto-char (point-min))
+ (while (progn
+ (skip-chars-forward "^&<>\"")
+ (not (eobp)))
+ (insert (cdr (assq (char-after (point))
+ '((?\" . "&quot;")
+ (?& . "&amp;")
+ (?< . "&lt;")
+ (?> . "&gt;")))))
+ (delete-char 1))
+ (buffer-string))
+ string))
+
+;;;###autoload
+(defun url-normalize-url (url)
+ "Return a 'normalized' version of URL.
+Strips out default port numbers, etc."
+ (let (type data grok retval)
+ (setq data (url-generic-parse-url url)
+ type (url-type data))
+ (if (member type '("www" "about" "mailto" "info"))
+ (setq retval url)
+ (url-set-target data nil)
+ (setq retval (url-recreate-url data)))
+ retval))
+
+;;;###autoload
+(defun url-lazy-message (&rest args)
+ "Just like `message', but is a no-op if called more than once a second.
+Will not do anything if `url-show-status' is nil."
+ (if (or (null url-show-status)
+ (active-minibuffer-window)
+ (= url-lazy-message-time
+ (setq url-lazy-message-time (nth 1 (current-time)))))
+ nil
+ (apply 'message args)))
+
+;;;###autoload
+(defun url-get-normalized-date (&optional specified-time)
+ "Return a 'real' date string that most HTTP servers can understand."
+ (require 'timezone)
+ (let* ((raw (if specified-time (current-time-string specified-time)
+ (current-time-string)))
+ (gmt (timezone-make-date-arpa-standard raw
+ (nth 1 (current-time-zone))
+ "GMT"))
+ (parsed (timezone-parse-date gmt))
+ (day (cdr-safe (assoc (substring raw 0 3) weekday-alist)))
+ (year nil)
+ (month (car
+ (rassoc
+ (string-to-int (aref parsed 1)) monthabbrev-alist)))
+ )
+ (setq day (or (car-safe (rassoc day weekday-alist))
+ (substring raw 0 3))
+ year (aref parsed 0))
+ ;; This is needed for plexus servers, or the server will hang trying to
+ ;; parse the if-modified-since header. Hopefully, I can take this out
+ ;; soon.
+ (if (and year (> (length year) 2))
+ (setq year (substring year -2 nil)))
+
+ (concat day ", " (aref parsed 2) "-" month "-" year " "
+ (aref parsed 3) " " (or (aref parsed 4)
+ (concat "[" (nth 1 (current-time-zone))
+ "]")))))
+
+;;;###autoload
+(defun url-eat-trailing-space (x)
+ "Remove spaces/tabs at the end of a string."
+ (let ((y (1- (length x)))
+ (skip-chars (list ? ?\t ?\n)))
+ (while (and (>= y 0) (memq (aref x y) skip-chars))
+ (setq y (1- y)))
+ (substring x 0 (1+ y))))
+
+;;;###autoload
+(defun url-strip-leading-spaces (x)
+ "Remove spaces at the front of a string."
+ (let ((y (1- (length x)))
+ (z 0)
+ (skip-chars (list ? ?\t ?\n)))
+ (while (and (<= z y) (memq (aref x z) skip-chars))
+ (setq z (1+ z)))
+ (substring x z nil)))
+
+;;;###autoload
+(defun url-pretty-length (n)
+ (cond
+ ((< n 1024)
+ (format "%d bytes" n))
+ ((< n (* 1024 1024))
+ (format "%dk" (/ n 1024.0)))
+ (t
+ (format "%2.2fM" (/ n (* 1024 1024.0))))))
+
+;;;###autoload
+(defun url-display-percentage (fmt perc &rest args)
+ (if (null fmt)
+ (if (fboundp 'clear-progress-display)
+ (clear-progress-display))
+ (if (and (fboundp 'progress-display) perc)
+ (apply 'progress-display fmt perc args)
+ (apply 'message fmt args))))
+
+;;;###autoload
+(defun url-percentage (x y)
+ (if (fboundp 'float)
+ (round (* 100 (/ x (float y))))
+ (/ (* x 100) y)))
+
+;;;###autoload
+(defun url-basepath (file &optional x)
+ "Return the base pathname of FILE, or the actual filename if X is true."
+ (cond
+ ((null file) "")
+ ((string-match (eval-when-compile (regexp-quote "?")) file)
+ (if x
+ (file-name-nondirectory (substring file 0 (match-beginning 0)))
+ (file-name-directory (substring file 0 (match-beginning 0)))))
+ (x (file-name-nondirectory file))
+ (t (file-name-directory file))))
+
+;;;###autoload
+(defun url-parse-query-string (query &optional downcase)
+ (let (retval pairs cur key val)
+ (setq pairs (split-string query "&"))
+ (while pairs
+ (setq cur (car pairs)
+ pairs (cdr pairs))
+ (if (not (string-match "=" cur))
+ nil ; Grace
+ (setq key (url-unhex-string (substring cur 0 (match-beginning 0)))
+ val (url-unhex-string (substring cur (match-end 0) nil)))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
+ retval))
+
+(defun url-unhex (x)
+ (if (> x ?9)
+ (if (>= x ?a)
+ (+ 10 (- x ?a))
+ (+ 10 (- x ?A)))
+ (- x ?0)))
+
+;; Fixme: Is this definition better, and does it ever matter?
+
+;; (defun url-unhex-string (str &optional allow-newlines)
+;; "Remove %XX, embedded spaces, etc in a url.
+;; If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+;; decoding of carriage returns and line feeds in the string, which is normally
+;; forbidden in URL encoding."
+;; (setq str (or str ""))
+;; (setq str (replace-regexp-in-string "%[[:xdigit:]]\\{2\\}"
+;; (lambda (match)
+;; (string (string-to-number
+;; (substring match 1) 16)))
+;; str t t))
+;; (if allow-newlines
+;; (replace-regexp-in-string "[\n\r]" (lambda (match)
+;; (format "%%%.2X" (aref match 0)))
+;; str t t)
+;; str))
+
+;;;###autoload
+(defun url-unhex-string (str &optional allow-newlines)
+ "Remove %XX embedded spaces, etc in a url.
+If optional second argument ALLOW-NEWLINES is non-nil, then allow the
+decoding of carriage returns and line feeds in the string, which is normally
+forbidden in URL encoding."
+ (setq str (or str ""))
+ (let ((tmp "")
+ (case-fold-search t))
+ (while (string-match "%[0-9a-f][0-9a-f]" str)
+ (let* ((start (match-beginning 0))
+ (ch1 (url-unhex (elt str (+ start 1))))
+ (code (+ (* 16 ch1)
+ (url-unhex (elt str (+ start 2))))))
+ (setq tmp (concat
+ tmp (substring str 0 start)
+ (cond
+ (allow-newlines
+ (char-to-string code))
+ ((or (= code ?\n) (= code ?\r))
+ " ")
+ (t (char-to-string code))))
+ str (substring str (match-end 0)))))
+ (setq tmp (concat tmp str))
+ tmp))
+
+(defconst url-unreserved-chars
+ '(
+ ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
+ ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
+ ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
+ "A list of characters that are _NOT_ reserved in the URL spec.
+This is taken from RFC 2396.")
+
+;;;###autoload
+(defun url-hexify-string (str)
+ "Escape characters in a string."
+ (mapconcat
+ (lambda (char)
+ ;; Fixme: use a char table instead.
+ (if (not (memq char url-unreserved-chars))
+ (if (> char 255)
+ (error "Hexifying multibyte character %s" str)
+ (format "%%%02X" char))
+ (char-to-string char)))
+ str ""))
+
+;;;###autoload
+(defun url-file-extension (fname &optional x)
+ "Return the filename extension of FNAME.
+If optional variable X is t,
+then return the basename of the file with the extension stripped off."
+ (if (and fname
+ (setq fname (url-basepath fname t))
+ (string-match "\\.[^./]+$" fname))
+ (if x (substring fname 0 (match-beginning 0))
+ (substring fname (match-beginning 0) nil))
+ ;;
+ ;; If fname has no extension, and x then return fname itself instead of
+ ;; nothing. When caching it allows the correct .hdr file to be produced
+ ;; for filenames without extension.
+ ;;
+ (if x
+ fname
+ "")))
+
+;;;###autoload
+(defun url-truncate-url-for-viewing (url &optional width)
+ "Return a shortened version of URL that is WIDTH characters or less wide.
+WIDTH defaults to the current frame width."
+ (let* ((fr-width (or width (frame-width)))
+ (str-width (length url))
+ (tail (file-name-nondirectory url))
+ (fname nil)
+ (modified 0)
+ (urlobj nil))
+ ;; The first thing that can go are the search strings
+ (if (and (>= str-width fr-width)
+ (string-match "?" url))
+ (setq url (concat (substring url 0 (match-beginning 0)) "?...")
+ str-width (length url)
+ tail (file-name-nondirectory url)))
+ (if (< str-width fr-width)
+ nil ; Hey, we are done!
+ (setq urlobj (url-generic-parse-url url)
+ fname (url-filename urlobj)
+ fr-width (- fr-width 4))
+ (while (and (>= str-width fr-width)
+ (string-match "/" fname))
+ (setq fname (substring fname (match-end 0) nil)
+ modified (1+ modified))
+ (url-set-filename urlobj fname)
+ (setq url (url-recreate-url urlobj)
+ str-width (length url)))
+ (if (> modified 1)
+ (setq fname (concat "/.../" fname))
+ (setq fname (concat "/" fname)))
+ (url-set-filename urlobj fname)
+ (setq url (url-recreate-url urlobj)))
+ url))
+
+;;;###autoload
+(defun url-view-url (&optional no-show)
+ "View the current document's URL.
+Optional argument NO-SHOW means just return the URL, don't show it in
+the minibuffer.
+
+This uses `url-current-object', set locally to the buffer."
+ (interactive)
+ (if (not url-current-object)
+ nil
+ (if no-show
+ (url-recreate-url url-current-object)
+ (message "%s" (url-recreate-url url-current-object)))))
+
+(eval-and-compile
+ (defvar url-get-url-filename-chars "-%.?@a-zA-Z0-9()_/:~=&"
+ "Valid characters in a URL")
+ )
+
+(defun url-get-url-at-point (&optional pt)
+ "Get the URL closest to point, but don't change position.
+Has a preference for looking backward when not directly on a symbol."
+ ;; Not at all perfect - point must be right in the name.
+ (save-excursion
+ (if pt (goto-char pt))
+ (let (start url)
+ (save-excursion
+ ;; first see if you're just past a filename
+ (if (not (eobp))
+ (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens
+ (progn
+ (skip-chars-backward " \n\t\r({[]})")
+ (if (not (bobp))
+ (backward-char 1)))))
+ (if (and (char-after (point))
+ (string-match (eval-when-compile
+ (concat "[" url-get-url-filename-chars "]"))
+ (char-to-string (char-after (point)))))
+ (progn
+ (skip-chars-backward url-get-url-filename-chars)
+ (setq start (point))
+ (skip-chars-forward url-get-url-filename-chars))
+ (setq start (point)))
+ (setq url (buffer-substring-no-properties start (point))))
+ (if (and url (string-match "^(.*)\\.?$" url))
+ (setq url (match-string 1 url)))
+ (if (and url (string-match "^URL:" url))
+ (setq url (substring url 4 nil)))
+ (if (and url (string-match "\\.$" url))
+ (setq url (substring url 0 -1)))
+ (if (and url (string-match "^www\\." url))
+ (setq url (concat "http://" url)))
+ (if (and url (not (string-match url-nonrelative-link url)))
+ (setq url nil))
+ url)))
+
+(defun url-generate-unique-filename (&optional fmt)
+ "Generate a unique filename in `url-temporary-directory'."
+ (if (not fmt)
+ (let ((base (format "url-tmp.%d" (user-real-uid)))
+ (fname "")
+ (x 0))
+ (setq fname (format "%s%d" base x))
+ (while (file-exists-p
+ (expand-file-name fname url-temporary-directory))
+ (setq x (1+ x)
+ fname (concat base (int-to-string x))))
+ (expand-file-name fname url-temporary-directory))
+ (let ((base (concat "url" (int-to-string (user-real-uid))))
+ (fname "")
+ (x 0))
+ (setq fname (format fmt (concat base (int-to-string x))))
+ (while (file-exists-p
+ (expand-file-name fname url-temporary-directory))
+ (setq x (1+ x)
+ fname (format fmt (concat base (int-to-string x)))))
+ (expand-file-name fname url-temporary-directory))))
+
+(defun url-extract-mime-headers ()
+ "Set `url-current-mime-headers' in current buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (unless url-current-mime-headers
+ (set (make-local-variable 'url-current-mime-headers)
+ (mail-header-extract)))))
+
+(provide 'url-util)
+
+;; arch-tag: 24352abc-5a5a-412e-90cd-313b26bed5c9
+;;; url-util.el ends here
diff --git a/lisp/vc-arch.el b/lisp/vc-arch.el
index c8efca02832..a439174556e 100644
--- a/lisp/vc-arch.el
+++ b/lisp/vc-arch.el
@@ -272,7 +272,7 @@ Return non-nil if FILE is unchanged."
;; Buh? Unexpected format.
'edited
(let ((ats (file-attributes file)))
- (if (and (= (nth 7 ats) (string-to-number (match-string 2)))
+ (if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
(equal (format-time-string "%s" (nth 5 ats))
(match-string 1)))
'up-to-date
@@ -375,7 +375,7 @@ Return non-nil if FILE is unchanged."
(vc-arch-command nil 0 file "commit" "-s" summary "-L" comment "--"
(vc-switches 'Arch 'checkin))))
-(defun vc-arch-diff (file &optional oldvers newvers)
+(defun vc-arch-diff (file &optional oldvers newvers buffer)
"Get a difference report using Arch between two versions of FILE."
(if (and newvers
(vc-up-to-date-p file)
@@ -390,7 +390,7 @@ Return non-nil if FILE is unchanged."
(default-directory (vc-arch-root file))
(status
(vc-arch-command
- "*vc-diff*"
+ (or buffer "*vc-diff*")
(if async 'async 1)
nil "file-diffs"
;; Arch does not support the typical flags.
diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el
index 80b9766caa0..3f5a46c5bea 100644
--- a/lisp/vc-hooks.el
+++ b/lisp/vc-hooks.el
@@ -6,7 +6,7 @@
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
-;; $Id: vc-hooks.el,v 1.165 2004/03/28 17:38:03 monnier Exp $
+;; $Id$
;; This file is part of GNU Emacs.
@@ -44,8 +44,8 @@
"set `vc-handled-backends' to nil to disable VC.")
(defvar vc-master-templates ())
-(make-obsolete-variable 'vc-master-templates
- "to define master templates for a given BACKEND, use
+(make-obsolete-variable 'vc-master-templates
+ "to define master templates for a given BACKEND, use
vc-BACKEND-master-templates. To enable or disable VC for a given
BACKEND, use `vc-handled-backends'.")
@@ -474,8 +474,8 @@ Return non-nil if FILE is unchanged."
(indirect-function
(vc-find-backend-function (vc-backend file)
'diff))))
- (not (eq (caddr err) 5)))
- (signal wrong-number-of-arguments err)
+ (not (eq (caddr err) 4)))
+ (signal (car err) (cdr err))
(vc-call diff file))))))
(defun vc-workfile-version (file)
diff --git a/lisp/vc-mcvs.el b/lisp/vc-mcvs.el
index 94beb7eb093..5c0bac48b3a 100644
--- a/lisp/vc-mcvs.el
+++ b/lisp/vc-mcvs.el
@@ -438,17 +438,17 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
;;; History functions
;;;
-(defun vc-mcvs-print-log (file)
+(defun vc-mcvs-print-log (file &optional buffer)
"Get change log associated with FILE."
(let ((default-directory (vc-mcvs-root file)))
;; Run the command from the root dir so that `mcvs filt' returns
;; valid relative names.
(vc-mcvs-command
- nil
+ buffer
(if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
file "log")))
-(defun vc-mcvs-diff (file &optional oldvers newvers)
+(defun vc-mcvs-diff (file &optional oldvers newvers buffer)
"Get a difference report using Meta-CVS between two versions of FILE."
(if (string= (vc-workfile-version file) "0")
;; This file is added but not yet committed; there is no master file.
@@ -457,7 +457,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
;; We regard this as "changed".
;; Diff it against /dev/null.
;; Note: this is NOT a "mcvs diff".
- (apply 'vc-do-command "*vc-diff*"
+ (apply 'vc-do-command (or buffer "*vc-diff*")
1 "diff" file
(append (vc-switches nil 'diff) '("/dev/null")))
;; Even if it's empty, it's locally modified.
@@ -467,7 +467,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
;; valid relative names.
(default-directory (vc-mcvs-root file))
(status
- (apply 'vc-mcvs-command "*vc-diff*"
+ (apply 'vc-mcvs-command (or buffer "*vc-diff*")
(if async 'async 1)
file "diff"
(and oldvers (concat "-r" oldvers))
diff --git a/lisp/vc-svn.el b/lisp/vc-svn.el
index 08af8f01977..82c09cbd435 100644
--- a/lisp/vc-svn.el
+++ b/lisp/vc-svn.el
@@ -195,8 +195,9 @@ This is only possible if SVN is responsible for FILE's directory.")
(defun vc-svn-checkin (file rev comment)
"SVN-specific version of `vc-backend-checkin'."
- (let ((status (apply 'vc-svn-command nil 1 file
- "ci" (list* "-m" comment (vc-switches 'SVN 'checkin)))))
+ (let ((status (apply
+ 'vc-svn-command nil 1 file "ci"
+ (nconc (list "-m" comment) (vc-switches 'SVN 'checkin)))))
(set-buffer "*vc*")
(goto-char (point-min))
(unless (equal status 0)
@@ -334,21 +335,22 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
;;; History functions
;;;
-(defun vc-svn-print-log (file)
+(defun vc-svn-print-log (file &optional buffer)
"Get change log associated with FILE."
(save-current-buffer
- (vc-setup-buffer nil)
+ (vc-setup-buffer buffer)
(let ((inhibit-read-only t))
(goto-char (point-min))
;; Add a line to tell log-view-mode what file this is.
(insert "Working file: " (file-relative-name file) "\n"))
(vc-svn-command
- t
+ buffer
(if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0)
file "log")))
-(defun vc-svn-diff (file &optional oldvers newvers)
+(defun vc-svn-diff (file &optional oldvers newvers buffer)
"Get a difference report using SVN between two versions of FILE."
+ (unless buffer (setq buffer "*vc-diff*"))
(if (string= (vc-workfile-version file) "0")
;; This file is added but not yet committed; there is no master file.
(if (or oldvers newvers)
@@ -356,7 +358,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
;; We regard this as "changed".
;; Diff it against /dev/null.
;; Note: this is NOT a "svn diff".
- (apply 'vc-do-command "*vc-diff*"
+ (apply 'vc-do-command buffer
1 "diff" file
(append (vc-switches nil 'diff) '("/dev/null")))
;; Even if it's empty, it's locally modified.
@@ -365,7 +367,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
(async (and (vc-stay-local-p file)
(or oldvers newvers) ; Svn diffs those locally.
(fboundp 'start-process))))
- (apply 'vc-svn-command "*vc-diff*"
+ (apply 'vc-svn-command buffer
(if async 'async 0)
file "diff"
(append
@@ -377,7 +379,7 @@ The changes are between FIRST-VERSION and SECOND-VERSION."
(if async 1 ; async diff => pessimistic assumption
;; For some reason `svn diff' does not return a useful
;; status w.r.t whether the diff was empty or not.
- (buffer-size (get-buffer "*vc-diff*"))))))
+ (buffer-size (get-buffer buffer))))))
(defun vc-svn-diff-tree (dir &optional rev1 rev2)
"Diff all files at and below DIR."
diff --git a/lisp/vc.el b/lisp/vc.el
index 801cf6d5759..1b4e2409550 100644
--- a/lisp/vc.el
+++ b/lisp/vc.el
@@ -7,7 +7,7 @@
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
;; Keywords: tools
-;; $Id: vc.el,v 1.374 2004/03/28 22:00:19 monnier Exp $
+;; $Id$
;; This file is part of GNU Emacs.
@@ -2357,11 +2357,11 @@ If FOCUS-REV is non-nil, leave the point at that revision."
;; without the optional buffer argument (for backward compatibility).
;; Otherwise, resignal.
(if (or (not (eq (cadr err)
- (indirect-function
- (vc-find-backend-function (vc-backend file)
+ (indirect-function
+ (vc-find-backend-function (vc-backend file)
'print-log))))
(not (eq (caddr err) 2)))
- (signal wrong-number-of-arguments err)
+ (signal (car err) (cdr err))
;; for backward compatibility
(vc-call print-log file)
(set-buffer "*vc*"))))
diff --git a/lisp/version.el b/lisp/version.el
index ef6a40f540d..dbd6142641e 100644
--- a/lisp/version.el
+++ b/lisp/version.el
@@ -61,9 +61,9 @@ to the system configuration; look at `system-configuration' instead."
system-configuration
(cond ((featurep 'motif)
(concat ", " (substring motif-version-string 4)))
- ((featurep 'x-toolkit) ", X toolkit")
((featurep 'gtk)
(concat ", GTK+ Version " gtk-version-string))
+ ((featurep 'x-toolkit) ", X toolkit")
(t ""))
(if (and (boundp 'x-toolkit-scroll-bars)
(memq x-toolkit-scroll-bars '(xaw xaw3d)))
diff --git a/lisp/view.el b/lisp/view.el
index 1ee6014c73a..b17cd52ae35 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -137,6 +137,7 @@ subtracted from by `view-mode-exit' when finished viewing the buffer.
See RETURN-TO-ALIST argument of function `view-mode-exit' for the format of
`view-return-to-alist'.")
(make-variable-buffer-local 'view-return-to-alist)
+(put 'view-return-to-alist 'permanent-local t)
(defvar view-exit-action nil
"nil or a function with one argument (a buffer) called when finished viewing.
diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el
index 54f051ef5e6..815f4d5382f 100644
--- a/lisp/w32-fns.el
+++ b/lisp/w32-fns.el
@@ -1,6 +1,6 @@
;;; w32-fns.el --- Lisp routines for Windows NT
-;; Copyright (C) 1994, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 2001, 2004 Free Software Foundation, Inc.
;; Author: Geoff Voelker <voelker@cs.washington.edu>
;; Keywords: internal
@@ -54,7 +54,8 @@ numbers, and the build number."
(x-server-version))
(defun w32-using-nt ()
- "Return non-nil if literally running on Windows NT (i.e., not Windows 9X)."
+ "Return non-nil if running on a 32-bit Windows system.
+That includes all Windows systems except for 9X/Me."
(and (eq system-type 'windows-nt) (getenv "SystemRoot")))
(defun w32-shell-name ()
@@ -71,7 +72,7 @@ numbers, and the build number."
w32-system-shells)))
(defun w32-shell-dos-semantics ()
- "Return t if the interactive shell being used expects msdos shell semantics."
+ "Return non-nil if the interactive shell being used expects MSDOS shell semantics."
(or (w32-system-shell-p (w32-shell-name))
(and (member (downcase (file-name-nondirectory (w32-shell-name)))
'("cmdproxy" "cmdproxy.exe"))
@@ -229,9 +230,13 @@ You should set this to t when using a non-system shell.\n\n"))))
(defun convert-standard-filename (filename)
"Convert a standard file's name to something suitable for the current OS.
-This function's standard definition is trivial; it just returns the argument.
-However, on some systems, the function is redefined
-with a definition that really does change some file names."
+This means to guarantee valid names and perhaps to canonicalize
+certain patterns.
+
+On Windows and DOS, replace invalid characters. On DOS, make
+sure to obey the 8.3 limitations. On Windows, turn Cygwin names
+into native names, and also turn slashes into backslashes if the
+shell requires it (see `w32-shell-dos-semantics')."
(let ((name
(save-match-data
(if (string-match "\\`/cygdrive/\\([a-zA-Z]\\)/" filename)
@@ -265,13 +270,13 @@ with a definition that really does change some file names."
(get 'x-selections type))
(defun set-w32-system-coding-system (coding-system)
- "Set the coding system used by the Windows System to CODING-SYSTEM.
+ "Set the coding system used by the Windows system to CODING-SYSTEM.
This is used for things like passing font names with non-ASCII
characters in them to the system. For a list of possible values of
CODING-SYSTEM, use \\[list-coding-systems].
This function is provided for backward compatibility, since
-w32-system-coding-system is now an alias for `locale-coding-system'."
+`w32-system-coding-system' is now an alias for `locale-coding-system'."
(interactive
(list (let ((default locale-coding-system))
(read-coding-system
diff --git a/lisp/wdired.el b/lisp/wdired.el
new file mode 100644
index 00000000000..30ba2a3cd45
--- /dev/null
+++ b/lisp/wdired.el
@@ -0,0 +1,873 @@
+;;; wdired.el --- Rename files editing their names in dired buffers
+
+;; Copyright (C) 2001, 2004 Free Software Foundation, Inc.
+
+;; Filename: wdired.el
+;; Author: Juan León Lahoz García <juan-leon.lahoz@tecsidel.es>
+;; Version: 1.91
+;; Keywords: dired, environment, files, renaming
+
+;; 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 2, 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; wdired.el (the "w" is for writable) provides an alternative way of
+;; renaming files.
+;;
+;; Have you ever wished to use C-x r t (string-rectangle), M-%
+;; (query-replace), M-c (capitalize-word), etc. to change the name of
+;; the files in a "dired" buffer? Now you can do this. All the power
+;; of emacs commands are available to renaming files!
+;;
+;; This package provides a function that makes the filenames of a a
+;; dired buffer editable, by changing the buffer mode (which inhibits
+;; all of the commands of dired mode). Here you can edit the names of
+;; one or more files and directories, and when you press C-c C-c, the
+;; renaming takes effect and you are back to dired mode.
+;;
+;; Another things you can do with wdired:
+;;
+;; - To move files to another directory (by typing their path,
+;; absolute or relative, as a part of the new filename).
+;;
+;; - To change the target of symbolic links.
+;;
+;; - To change the permission bits of the filenames (in systems with a
+;; working unix-alike `dired-chmod-program'). See and customize the
+;; variable `wdired-allow-to-change-permissions'. To change a single
+;; char (toggling between its two more usual values) you can press
+;; the space bar over it or left-click the mouse. To set any char to
+;; an specific value (this includes the SUID, SGID and STI bits) you
+;; can use the key labeled as the letter you want. Please note that
+;; permissions of the links cannot be changed in that way, because
+;; the change would affect to their targets, and this would not be
+;; WYSIWYG :-).
+;;
+;; - To mark files for deletion, by deleting their whole filename.
+;;
+;; I do not have a URL to hang wdired, but you can use the one below
+;; to find the latest version:
+;;
+;; http://groups.google.com/groups?as_ugroup=gnu.emacs.sources&as_q=wdired
+
+;;; Installation:
+
+;; Add this file (byte-compiling it is recommended) to your load-path.
+;; Then add one of these set of lines (or similar ones) to your config:
+;;
+;; This is the easy way:
+;;
+;; (require 'wdired)
+;; (define-key dired-mode-map "r" 'wdired-change-to-wdired-mode)
+;;
+;; This is recommended way for faster emacs startup time and lower
+;; memory consumption, but remind to add these lines before dired.el
+;; gets loaded (i.e., near the beginning of your .emacs file):
+;;
+;; (autoload 'wdired-change-to-wdired-mode "wdired")
+;; (add-hook 'dired-load-hook
+;; '(lambda ()
+;; (define-key dired-mode-map "r" 'wdired-change-to-wdired-mode)
+;; (define-key dired-mode-map
+;; [menu-bar immediate wdired-change-to-wdired-mode]
+;; '("Edit File Names" . wdired-change-to-wdired-mode))))
+;;
+;;
+;; Type "M-x customize-group RET wdired" if you want make changes to
+;; the default behavior.
+
+;;; Usage:
+
+;; Then, you can start editing the names of the files by typing "r"
+;; (or whatever key you choose, or M-x wdired-change-to-wdired-mode).
+;; Use C-c C-c when finished or C-c C-k to abort. You can use also the
+;; menu options: in dired mode, "Edit File Names" under "Immediate".
+;; While editing the names, a new submenu "WDired" is available at top
+;; level. You can customize the behavior of this package from this
+;; menu.
+
+;;; Change Log:
+
+;; From 1.9 to 1.91
+;;
+;; - Fixed a bug (introduced in 1.9) so now files can be marked for
+;; deletion again, by deleting their whole filename.
+
+;; From 1.8 to 1.9
+;;
+;; - Another alternative way of editing permissions allowed, see
+;; `wdired-allow-to-change-permissions' for details.
+;;
+;; - Now wdired doesn't rely on regexp so much. As a consequence of
+;; this, you can add newlines to filenames and symlinks targets
+;; (although this is not very usual, IMHO). Please note that dired
+;; (at least in Emacs 21.1 and previous) does not work very well
+;; with filenames with newlines in them, so RET is deactivated in
+;; wdired mode. But you can activate it if you want.
+;;
+;; - Now `upcase-word' `capitalize-word' and `downcase-word' are not
+;; advised to work better with wdired mode, but the keys bound to
+;; them use wdired versions of those commands.
+;;
+;; - Now "undo" actions are not inherited from wdired mode when
+;; changing to dired mode.
+;;
+;; - Code and documentation cleanups.
+;;
+;; - Fixed a bug that was making wdired to fail on users with
+;; `dired-backup-overwrite' set to t.
+;;
+;; - C-c C-[ now abort changes.
+
+;; From 1.7 to 1.8
+;;
+;; - Now permission (access-control) bits of the files can be changed.
+;; Please see the commentary section and the custom variable
+;; `wdired-allow-to-change-permissions' for details.
+;;
+;; - Added another possible value for the variable
+;; `wdired-always-move-to-filename-beginning', useful to change
+;; permission bits of several files without the cursor jumping to
+;; filenames when changing lines.
+
+;; From 0.1 to 1.7
+
+;; - I've moved the list of changes to another file, because it was
+;; huge. Ask me for it or search older versions in google.
+
+;;; TODO:
+
+;; - Make it to work in XEmacs. Any volunteer?
+
+;;; Code:
+
+(eval-when-compile
+ (require 'advice)
+ (defvar dired-backup-overwrite) ; Only in emacs 20.x this is a custom var
+ (set (make-local-variable 'byte-compile-dynamic) t))
+
+(eval-and-compile
+ (require 'dired)
+ (autoload 'dired-do-create-files-regexp "dired-aux")
+ (autoload 'dired-call-process "dired-aux"))
+
+(defgroup wdired nil
+ "Mode to rename files by editing their names in dired buffers."
+ :group 'dired)
+
+(defcustom wdired-use-interactive-rename nil
+ "*If t, confirmation is required before actually rename the files.
+Confirmation is required also for overwriting files. If nil, no
+confirmation is required for change the file names, and the variable
+`wdired-is-ok-overwrite' is used to see if it is ok to overwrite files
+without asking."
+ :type 'boolean
+ :group 'wdired)
+
+(defcustom wdired-is-ok-overwrite nil
+ "*If non-nil the renames can overwrite files without asking.
+This variable is used only if `wdired-use-interactive-rename' is nil."
+ :type 'boolean
+ :group 'wdired)
+
+(defcustom wdired-always-move-to-filename-beginning nil
+ "*If t the \"up\" and \"down\" movement is done as in dired mode.
+That is, always move the point to the beginning of the filename at line.
+
+If `sometimes, only move to the beginning of filename if the point is
+before it, and `track-eol' is honored. This behavior is very handy
+when editing several filenames.
+
+If nil, \"up\" and \"down\" movement is done as in any other buffer."
+ :type '(choice (const :tag "As in any other mode" nil)
+ (const :tag "Smart cursor placement" sometimes)
+ (other :tag "As in dired mode" t))
+ :group 'wdired)
+
+(defcustom wdired-advise-functions t
+ "*If t some editing commands are advised when wdired is loaded.
+The advice only has effect in wdired mode. These commands are
+`query-replace' `query-replace-regexp' `replace-string', and the
+advice makes them to ignore read-only regions, so no attempts to
+modify these regions are done by them, and so they don't end
+prematurely.
+
+Setting this to nil does not unadvise the functions, if they are
+already advised, but new Emacs will not advise them."
+ :type 'boolean
+ :group 'wdired)
+
+(defcustom wdired-allow-to-redirect-links t
+ "*If non-nil, the target of the symbolic links can be changed also.
+In systems without symbolic links support, this variable has no effect
+at all."
+ :type 'boolean
+ :group 'wdired)
+
+(defcustom wdired-allow-to-change-permissions nil
+ "*If non-nil, the permissions bits of the files can be changed also.
+
+If t, to change a single bit, put the cursor over it and press the
+space bar, or left click over it. You can also hit the letter you want
+to set: if this value is allowed, the character in the buffer will be
+changed. Anyway, the point is advanced one position, so, for example,
+you can keep the \"x\" key pressed to give execution permissions to
+everybody to that file.
+
+If `advanced, the bits are freely editable. You can use
+`string-rectangle', `query-replace', etc. You can put any value (even
+newlines), but if you want your changes to be useful, you better put a
+intelligible value.
+
+Anyway, the real change of the permissions is done with the external
+program `dired-chmod-program', which must exist."
+ :type '(choice (const :tag "Not allowed" nil)
+ (const :tag "Toggle/set bits" t)
+ (other :tag "Bits freely editable" advanced))
+ :group 'wdired)
+
+(defvar wdired-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-x\C-s" 'wdired-finish-edit)
+ (define-key map "\C-c\C-c" 'wdired-finish-edit)
+ (define-key map "\C-c\C-k" 'wdired-abort-changes)
+ (define-key map "\C-c\C-[" 'wdired-abort-changes)
+ (define-key map "\C-m" 'wdired-newline)
+ (define-key map "\C-j" 'wdired-newline)
+ (define-key map "\C-o" 'wdired-newline)
+ (define-key map [up] 'wdired-previous-line)
+ (define-key map "\C-p" 'wdired-previous-line)
+ (define-key map [down] 'wdired-next-line)
+ (define-key map "\C-n" 'wdired-next-line)
+
+ (define-key map [menu-bar wdired]
+ (cons "WDired" (make-sparse-keymap "WDired")))
+ (define-key map [menu-bar wdired wdired-customize]
+ '("Options" . wdired-customize))
+ (define-key map [menu-bar wdired dashes]
+ '("--"))
+ (define-key map [menu-bar wdired wdired-abort-changes]
+ '("Abort Changes" . wdired-abort-changes))
+ (define-key map [menu-bar wdired wdired-finish-edit]
+ '("Commit Changes" . wdired-finish-edit))
+ ;; FIXME: Use the new remap trick.
+ (substitute-key-definition 'upcase-word 'wdired-upcase-word
+ map global-map)
+ (substitute-key-definition 'capitalize-word 'wdired-capitalize-word
+ map global-map)
+ (substitute-key-definition 'downcase-word 'wdired-downcase-word
+ map global-map)
+ map))
+
+(defvar wdired-mode-hook nil
+ "Hook run when changing to wdired mode.")
+
+;; Local variables (put here to avoid compilation gripes)
+(defvar wdired-col-perm) ;; Column where the permission bits start
+(defvar wdired-old-content)
+
+
+(defun wdired-mode ()
+ "\\<wdired-mode-map>File Names Editing mode.
+
+Press \\[wdired-finish-edit] to make the changes to take effect and
+exit. To abort the edit, use \\[wdired-abort-changes].
+
+In this mode you can edit the names of the files, the target of the
+links and the permission bits of the files. You can `customize-group'
+wdired.
+
+Editing things out of the filenames, or adding or deleting lines is
+not allowed, because the rest of the buffer is read-only."
+ (interactive)
+ (error "This mode can be enabled only by `wdired-change-to-wdired-mode'"))
+(put 'wdired-mode 'mode-class 'special)
+
+
+;;;###autoload
+(defun wdired-change-to-wdired-mode ()
+ "Put a dired buffer in a mode in which filenames are editable.
+In this mode the names of the files can be changed, and after
+typing C-c C-c the files and directories in disk are renamed.
+
+See `wdired-mode'."
+ (interactive)
+ (set (make-local-variable 'wdired-old-content)
+ (buffer-substring (point-min) (point-max)))
+ (use-local-map wdired-mode-map)
+ (force-mode-line-update)
+ (setq buffer-read-only nil)
+ (dired-unadvertise default-directory)
+ (add-hook 'kill-buffer-hook 'wdired-check-kill-buffer nil t)
+ (setq major-mode 'wdired-mode)
+ (setq mode-name "Edit filenames")
+ (setq revert-buffer-function 'wdired-revert)
+ ;; I temp disable undo for performance: since I'm going to clear the
+ ;; undo list, it can save more than a 9% of time with big
+ ;; directories because setting properties modify the undo-list.
+ (buffer-disable-undo)
+ (wdired-preprocess-files)
+ (if wdired-allow-to-change-permissions
+ (wdired-preprocess-perms))
+ (if (and wdired-allow-to-redirect-links (fboundp 'make-symbolic-link))
+ (wdired-preprocess-symlinks))
+ (buffer-enable-undo) ; Performance hack. See above.
+ (set-buffer-modified-p nil)
+ (setq buffer-undo-list nil)
+ (run-hooks 'wdired-mode-hook)
+ (message (substitute-command-keys "Press \\[wdired-finish-edit] when finished")))
+
+
+;; Protect the buffer so only the filenames can be changed, and put
+;; properties so filenames (old and new) can be easily found.
+(defun wdired-preprocess-files ()
+ (put-text-property 1 2 'front-sticky t)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((b-protection (point))
+ filename)
+ (while (not (eobp))
+ (setq filename (dired-get-filename nil t))
+ (when (and filename
+ (not (member (file-name-nondirectory filename) '("." ".."))))
+ (dired-move-to-filename)
+ (put-text-property (- (point) 2) (1- (point)) 'old-name filename)
+ (put-text-property b-protection (1- (point)) 'read-only t)
+ (setq b-protection (dired-move-to-end-of-filename t)))
+ (put-text-property (point) (1+ (point)) 'end-name t)
+ (forward-line))
+ (put-text-property b-protection (point-max) 'read-only t))))
+
+;; This code is a copy of some dired-get-filename lines.
+(defsubst wdired-normalize-filename (file)
+ (setq file
+ ;; FIXME: shouldn't we check for a `b' argument or somesuch before
+ ;; doing such unquoting? --Stef
+ (read (concat
+ "\"" (replace-regexp-in-string
+ "\\([^\\]\\|\\`\\)\"" "\\1\\\\\"" file)
+ "\"")))
+ (and file buffer-file-coding-system
+ (not file-name-coding-system)
+ (not default-file-name-coding-system)
+ (setq file (encode-coding-string file buffer-file-coding-system)))
+ file)
+
+(defun wdired-get-filename (&optional no-dir old)
+ "Return the filename at line.
+Similar to `dired-get-filename' but it doesn't rely on regexps. It
+relies on wdired buffer's properties. Optional arg NO-DIR with value
+non-nil means don't include directory. Optional arg OLD with value
+non-nil means return old filename."
+ ;; FIXME: Use dired-get-filename's new properties.
+ (let (beg end file)
+ (save-excursion
+ (setq end (progn (end-of-line) (point)))
+ (beginning-of-line)
+ (setq beg (next-single-property-change (point) 'old-name nil end))
+ (unless (eq beg end)
+ (if old
+ (setq file (get-text-property beg 'old-name))
+ (setq end (next-single-property-change (1+ beg) 'end-name))
+ (setq file (buffer-substring-no-properties (+ 2 beg) end)))
+ (and file (setq file (wdired-normalize-filename file))))
+ (if (or no-dir old)
+ file
+ (and file (> (length file) 0)
+ (concat (dired-current-directory) file))))))
+
+
+(defun wdired-change-to-dired-mode ()
+ "Change the mode back to dired."
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max)
+ '(read-only nil local-map nil)))
+ (put-text-property 1 2 'front-sticky nil)
+ (use-local-map dired-mode-map)
+ (force-mode-line-update)
+ (setq buffer-read-only t)
+ (setq major-mode 'dired-mode)
+ (setq mode-name "Dired")
+ (dired-advertise)
+ (remove-hook 'kill-buffer-hook 'wdired-check-kill-buffer t)
+ (setq revert-buffer-function 'dired-revert))
+
+
+(defun wdired-abort-changes ()
+ "Abort changes and return to dired mode."
+ (interactive)
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert wdired-old-content))
+ (wdired-change-to-dired-mode)
+ (set-buffer-modified-p nil)
+ (setq buffer-undo-list nil)
+ (message "Changes aborted"))
+
+(defun wdired-finish-edit ()
+ "Actually rename files based on your editing in the Dired buffer."
+ (interactive)
+ (wdired-change-to-dired-mode)
+ (let ((overwrite (or wdired-is-ok-overwrite 1))
+ (changes nil)
+ (files-deleted nil)
+ (errors 0)
+ file-ori file-new tmp-value)
+ (save-excursion
+ (if (and wdired-allow-to-redirect-links
+ (fboundp 'make-symbolic-link))
+ (progn
+ (setq tmp-value (wdired-do-symlink-changes))
+ (setq errors (cdr tmp-value))
+ (setq changes (car tmp-value))))
+ (if (and wdired-allow-to-change-permissions
+ (boundp 'wdired-col-perm)) ; could have been changed
+ (progn
+ (setq tmp-value (wdired-do-perm-changes))
+ (setq errors (+ errors (cdr tmp-value)))
+ (setq changes (or changes (car tmp-value)))))
+ (goto-char (point-max))
+ (while (not (bobp))
+ (setq file-ori (wdired-get-filename nil t))
+ (if file-ori
+ (setq file-new (wdired-get-filename)))
+ (if (and file-ori (not (equal file-new file-ori)))
+ (progn
+ (setq changes t)
+ (if (not file-new) ;empty filename!
+ (setq files-deleted (cons file-ori files-deleted))
+ (progn
+ (setq file-new (substitute-in-file-name file-new))
+ (if wdired-use-interactive-rename
+ (wdired-search-and-rename file-ori file-new)
+ (condition-case err
+ (let ((dired-backup-overwrite nil))
+ (dired-rename-file file-ori file-new
+ overwrite))
+ (error
+ (setq errors (1+ errors))
+ (dired-log (concat "Rename `" file-ori "' to `"
+ file-new "' failed:\n%s\n")
+ err))))))))
+ (forward-line -1)))
+ (if changes
+ (revert-buffer) ;The "revert" is necessary to re-sort the buffer
+ (let ((buffer-read-only nil))
+ (remove-text-properties (point-min) (point-max)
+ '(old-name nil end-name nil old-link nil
+ end-link nil end-perm nil
+ old-perm nil perm-changed nil))
+ (message "(No changes to be performed)")))
+ (if files-deleted
+ (wdired-flag-for-deletion files-deleted))
+ (if (> errors 0)
+ (dired-log-summary (format "%d rename actions failed" errors) nil)))
+ (set-buffer-modified-p nil)
+ (setq buffer-undo-list nil))
+
+;; Renames a file, searching it in a modified dired buffer, in order
+;; to be able to use `dired-do-create-files-regexp' and get its
+;; "benefits"
+(defun wdired-search-and-rename (filename-ori filename-new)
+ (save-excursion
+ (goto-char (point-max))
+ (forward-line -1)
+ (let ((exit-while nil)
+ curr-filename)
+ (while (not exit-while)
+ (setq curr-filename (wdired-get-filename))
+ (if (and curr-filename
+ (equal (substitute-in-file-name curr-filename) filename-new))
+ (progn
+ (setq exit-while t)
+ (let ((inhibit-read-only t))
+ (dired-move-to-filename)
+ (search-forward (wdired-get-filename t) nil t)
+ (replace-match (file-name-nondirectory filename-ori) t t))
+ (dired-do-create-files-regexp
+ (function dired-rename-file)
+ "Move" 1 ".*" filename-new nil t))
+ (progn
+ (forward-line -1)
+ (beginning-of-line)
+ (setq exit-while (= 1 (point)))))))))
+
+;; marks a list of files for deletion
+(defun wdired-flag-for-deletion (filenames-ori)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (member (dired-get-filename nil t) filenames-ori)
+ (dired-flag-file-deletion 1)
+ (forward-line)))))
+
+(defun wdired-customize ()
+ "Customize wdired options."
+ (interactive)
+ (customize-apropos "wdired" 'groups))
+
+(defun wdired-revert (&optional arg noconfirm)
+ "Discard changes in the buffer and update the changes in the disk."
+ (wdired-change-to-dired-mode)
+ (revert-buffer)
+ (wdired-change-to-wdired-mode))
+
+(defun wdired-check-kill-buffer ()
+ ;; FIXME: Can't we use the normal mechanism for that? --Stef
+ (if (and
+ (buffer-modified-p)
+ (not (y-or-n-p "Buffer changed. Discard changes and kill buffer? ")))
+ (error nil)))
+
+(defun wdired-next-line (arg)
+ "Move down lines then position at filename or the current column.
+See `wdired-always-move-to-filename-beginning'. Optional prefix ARG
+says how many lines to move; default is one line."
+ (interactive "p")
+ (next-line arg)
+ (if (or (eq wdired-always-move-to-filename-beginning t)
+ (and wdired-always-move-to-filename-beginning
+ (< (current-column)
+ (save-excursion (dired-move-to-filename)
+ (current-column)))))
+ (dired-move-to-filename)))
+
+(defun wdired-previous-line (arg)
+ "Move up lines then position at filename or the current column.
+See `wdired-always-move-to-filename-beginning'. Optional prefix ARG
+says how many lines to move; default is one line."
+ (interactive "p")
+ (previous-line arg)
+ (if (or (eq wdired-always-move-to-filename-beginning t)
+ (and wdired-always-move-to-filename-beginning
+ (< (current-column)
+ (save-excursion (dired-move-to-filename)
+ (current-column)))))
+ (dired-move-to-filename)))
+
+;; dired doesn't works well with newlines, so ...
+(defun wdired-newline ()
+ "Do nothing."
+ (interactive))
+
+;; Put the needed properties to allow the user to change links' targets
+(defun wdired-preprocess-symlinks ()
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at dired-re-sym)
+ (progn
+ (re-search-forward " -> \\(.*\\)$")
+ (put-text-property (- (match-beginning 1) 2)
+ (1- (match-beginning 1)) 'old-link
+ (match-string-no-properties 1))
+ (put-text-property (match-end 1) (1+ (match-end 1)) 'end-link t)
+ (put-text-property (1- (match-beginning 1))
+ (match-end 1) 'read-only nil)))
+ (forward-line)
+ (beginning-of-line)))))
+
+
+(defun wdired-get-previous-link (&optional old move)
+ "Return the next symlink target.
+If OLD, return the old target. If MOVE, move point before it."
+ (let (beg end target)
+ (setq beg (previous-single-property-change (point) 'old-link nil))
+ (if beg
+ (progn
+ (if old
+ (setq target (get-text-property (1- beg) 'old-link))
+ (setq end (next-single-property-change beg 'end-link))
+ (setq target (buffer-substring-no-properties (1+ beg) end)))
+ (if move (goto-char (1- beg)))))
+ (and target (wdired-normalize-filename target))))
+
+
+
+;; Perform the changes in the target of the changed links.
+(defun wdired-do-symlink-changes()
+ (let ((changes nil)
+ (errors 0)
+ link-to-ori link-to-new link-from)
+ (goto-char (point-max))
+ (while (setq link-to-new (wdired-get-previous-link))
+ (setq link-to-ori (wdired-get-previous-link t t))
+ (setq link-from (wdired-get-filename nil t))
+ (if (not (equal link-to-new link-to-ori))
+ (progn
+ (setq changes t)
+ (if (equal link-to-new "") ;empty filename!
+ (setq link-to-new "/dev/null"))
+ (condition-case err
+ (progn
+ (delete-file link-from)
+ (make-symbolic-link
+ (substitute-in-file-name link-to-new) link-from))
+ (error
+ (setq errors (1+ errors))
+ (dired-log (concat "Link `" link-from "' to `"
+ link-to-new "' failed:\n%s\n")
+ err))))))
+ (cons changes errors)))
+
+;; Perform a "case command" skipping read-only words.
+(defun wdired-xcase-word (command arg)
+ (if (< arg 0)
+ (funcall command arg)
+ (progn
+ (while (> arg 0)
+ (condition-case err
+ (progn
+ (funcall command 1)
+ (setq arg (1- arg)))
+ (error
+ (if (not (forward-word 1))
+ (setq arg 0))))))))
+
+(defun wdired-downcase-word (arg)
+ "Wdired version of `downcase-word'.
+Like original function but it skips read-only words."
+ (interactive "p")
+ (wdired-xcase-word 'downcase-word arg))
+
+(defun wdired-upcase-word (arg)
+ "Wdired version of `upcase-word'.
+Like original function but it skips read-only words."
+ (interactive "p")
+ (wdired-xcase-word 'upcase-word arg))
+
+(defun wdired-capitalize-word (arg)
+ "Wdired version of `capitalize-word'.
+Like original function but it skips read-only words."
+ (interactive "p")
+ (wdired-xcase-word 'capitalize-word arg))
+
+;; The following code is related to advice some interactive functions
+;; to make some editing commands in wdired mode not to fail trying to
+;; change read-only text. Notice that some advises advice and unadvise
+;; them-self to another functions: search-forward and
+;; re-search-forward. This is to keep these functions advised only
+;; when is necessary. Since they are built-in commands used heavily in
+;; lots of places, to have it permanently advised would cause some
+;; performance loss.
+
+
+(defun wdired-add-skip-in-replace (command)
+ "Advice COMMAND to skip matches while they have read-only properties.
+This is useful to avoid \"read-only\" errors in search and replace
+commands. This advice only has effect in wdired mode."
+ (eval
+ `(defadvice ,command (around wdired-discard-read-only activate)
+ ,(format "Make %s to work better with wdired,\n%s." command
+ "skipping read-only matches when invoked without argument")
+ ad-do-it
+ (if (eq major-mode 'wdired-mode)
+ (while (and ad-return-value
+ (text-property-any
+ (max 1 (1- (match-beginning 0))) (match-end 0)
+ 'read-only t))
+ ad-do-it))
+ ad-return-value)))
+
+
+(defun wdired-add-replace-advice (command)
+ "Advice COMMAND to skip matches while they have read-only properties.
+This is useful to avoid \"read-only\" errors in search and replace
+commands. This advice only has effect in wdired mode."
+ (eval
+ `(defadvice ,command (around wdired-grok-read-only activate)
+ ,(format "Make %s to work better with wdired,\n%s." command
+ "skipping read-only matches when invoked without argument")
+ (if (eq major-mode 'wdired-mode)
+ (progn
+ (wdired-add-skip-in-replace 'search-forward)
+ (wdired-add-skip-in-replace 're-search-forward)
+ (unwind-protect
+ ad-do-it
+ (progn
+ (ad-remove-advice 'search-forward
+ 'around 'wdired-discard-read-only)
+ (ad-remove-advice 're-search-forward
+ 'around 'wdired-discard-read-only)
+ (ad-update 'search-forward)
+ (ad-update 're-search-forward))))
+ ad-do-it)
+ ad-return-value)))
+
+
+(if wdired-advise-functions
+ (progn
+ (mapcar 'wdired-add-replace-advice
+ '(query-replace query-replace-regexp replace-string))))
+
+
+;; The following code deals with changing the access bits (or
+;; permissions) of the files.
+
+(defvar wdired-perm-mode-map nil)
+(unless wdired-perm-mode-map
+ (setq wdired-perm-mode-map (copy-keymap wdired-mode-map))
+ (define-key wdired-perm-mode-map " " 'wdired-toggle-bit)
+ (define-key wdired-perm-mode-map "r" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "w" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "x" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "-" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "S" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "s" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "T" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "t" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "s" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map "l" 'wdired-set-bit)
+ (define-key wdired-perm-mode-map [down-mouse-1] 'wdired-mouse-toggle-bit))
+
+;; Put a local-map to the permission bits of the files, and store the
+;; original name and permissions as a property
+(defun wdired-preprocess-perms()
+ (let ((inhibit-read-only t)
+ filename)
+ (set (make-local-variable 'wdired-col-perm) nil)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (and (not (looking-at dired-re-sym))
+ (setq filename (wdired-get-filename)))
+ (progn
+ (re-search-forward dired-re-perms)
+ (or wdired-col-perm
+ (setq wdired-col-perm (- (current-column) 9)))
+ (if (eq wdired-allow-to-change-permissions 'advanced)
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'read-only nil)
+ (put-text-property (1+ (match-beginning 0)) (match-end 0)
+ 'local-map wdired-perm-mode-map))
+ (put-text-property (match-end 0) (1+ (match-end 0)) 'end-perm t)
+ (put-text-property (match-beginning 0) (1+ (match-beginning 0))
+ 'old-perm (match-string-no-properties 0))))
+ (forward-line)
+ (beginning-of-line)))))
+
+(defun wdired-perm-allowed-in-pos (char pos)
+ (cond
+ ((= char ?-) t)
+ ((= char ?r) (= (% pos 3) 0))
+ ((= char ?w) (= (% pos 3) 1))
+ ((= char ?x) (= (% pos 3) 2))
+ ((memq char '(?s ?S)) (memq pos '(2 5)))
+ ((memq char '(?t ?T)) (= pos 8))
+ ((= char ?l) (= pos 5))))
+
+(defun wdired-set-bit ()
+ "Set a permission bit character."
+ (interactive)
+ (if (wdired-perm-allowed-in-pos last-command-char
+ (- (current-column) wdired-col-perm))
+ (let ((new-bit (char-to-string last-command-char))
+ (inhibit-read-only t)
+ (pos-prop (- (point) (- (current-column) wdired-col-perm))))
+ (put-text-property 0 1 'local-map wdired-perm-mode-map new-bit)
+ (put-text-property 0 1 'read-only t new-bit)
+ (insert new-bit)
+ (delete-char 1)
+ (put-text-property pos-prop (1- pos-prop) 'perm-changed t))
+ (forward-char 1)))
+
+(defun wdired-toggle-bit()
+ "Toggle the permission bit at point."
+ (interactive)
+ (let ((inhibit-read-only t)
+ (new-bit "-")
+ (pos-prop (- (point) (- (current-column) wdired-col-perm))))
+ (if (eq (char-after (point)) ?-)
+ (setq new-bit
+ (if (= (% (- (current-column) wdired-col-perm) 3) 0) "r"
+ (if (= (% (- (current-column) wdired-col-perm) 3) 1) "w"
+ "x"))))
+ (put-text-property 0 1 'local-map wdired-perm-mode-map new-bit)
+ (put-text-property 0 1 'read-only t new-bit)
+ (insert new-bit)
+ (delete-char 1)
+ (put-text-property pos-prop (1- pos-prop) 'perm-changed t)))
+
+(defun wdired-mouse-toggle-bit (event)
+ "Toggle the permission bit that was left clicked."
+ (interactive "e")
+ (mouse-set-point event)
+ (wdired-toggle-bit))
+
+;; Allowed chars for 4000 bit are Ss in position 3
+;; Allowed chars for 2000 bit are Ssl in position 6
+;; Allowed chars for 1000 bit are Tt in position 9
+(defun wdired-perms-to-number (perms)
+ (let ((nperm 0777))
+ (if (= (elt perms 1) ?-) (setq nperm (- nperm 400)))
+ (if (= (elt perms 2) ?-) (setq nperm (- nperm 200)))
+ (let ((p-bit (elt perms 3)))
+ (if (memq p-bit '(?- ?S)) (setq nperm (- nperm 100)))
+ (if (memq p-bit '(?s ?S)) (setq nperm (+ nperm 4000))))
+ (if (= (elt perms 4) ?-) (setq nperm (- nperm 40)))
+ (if (= (elt perms 5) ?-) (setq nperm (- nperm 20)))
+ (let ((p-bit (elt perms 6)))
+ (if (memq p-bit '(?- ?S ?l)) (setq nperm (- nperm 10)))
+ (if (memq p-bit '(?s ?S ?l)) (setq nperm (+ nperm 2000))))
+ (if (= (elt perms 7) ?-) (setq nperm (- nperm 4)))
+ (if (= (elt perms 8) ?-) (setq nperm (- nperm 2)))
+ (let ((p-bit (elt perms 9)))
+ (if (memq p-bit '(?- ?T)) (setq nperm (- nperm 1)))
+ (if (memq p-bit '(?t ?T)) (setq nperm (+ nperm 1000))))
+ nperm))
+
+;; Perform the changes in the permissions of the files that have
+;; changed.
+(defun wdired-do-perm-changes ()
+ (let ((changes nil)
+ (errors 0)
+ (prop-wanted (if (eq wdired-allow-to-change-permissions 'advanced)
+ 'old-perm 'perm-changed))
+ filename perms-ori perms-new perm-tmp)
+ (goto-char (next-single-property-change (point-min) prop-wanted
+ nil (point-max)))
+ (while (not (eobp))
+ (setq perms-ori (get-text-property (point) 'old-perm))
+ (setq perms-new (buffer-substring-no-properties
+ (point) (next-single-property-change (point) 'end-perm)))
+ (if (not (equal perms-ori perms-new))
+ (progn
+ (setq changes t)
+ (setq filename (wdired-get-filename nil t))
+ (if (= (length perms-new) 10)
+ (progn
+ (setq perm-tmp
+ (int-to-string (wdired-perms-to-number perms-new)))
+ (if (not (equal 0 (dired-call-process dired-chmod-program
+ t perm-tmp filename)))
+ (progn
+ (setq errors (1+ errors))
+ (dired-log (concat dired-chmod-program " " perm-tmp
+ " `" filename "' failed\n\n")))))
+ (setq errors (1+ errors))
+ (dired-log (concat "Cannot parse permission `" perms-new
+ "' for file `" filename "'\n\n")))))
+ (goto-char (next-single-property-change (1+ (point)) prop-wanted
+ nil (point-max))))
+ (cons changes errors)))
+
+(provide 'wdired)
+
+;; arch-tag: bc00902e-526f-4305-bc7f-8862a559184f
+;;; wdired.el ends here
diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index dd55b35caac..e6ce5ae71db 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -382,10 +382,11 @@ new value.")
(setq help-echo 'widget-mouse-help))
(overlay-put overlay 'button widget)
(overlay-put overlay 'keymap (widget-get widget :keymap))
+ (overlay-put overlay 'evaporate t)
;; We want to avoid the face with image buttons.
(unless (widget-get widget :suppress-face)
- (overlay-put overlay 'face (widget-apply widget :button-face-get))
- (overlay-put overlay 'mouse-face widget-mouse-face))
+ (overlay-put overlay 'face (widget-apply widget :button-face-get)))
+ (overlay-put overlay 'pointer 'hand)
(overlay-put overlay 'help-echo help-echo)))
(defun widget-mouse-help (window overlay point)
@@ -401,6 +402,7 @@ new value.")
"Specify sample for WIDGET between FROM and TO."
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face (widget-apply widget :sample-face-get))
+ (overlay-put overlay 'evaporate t)
(widget-put widget :sample-overlay overlay)))
(defun widget-specify-doc (widget from to)
@@ -408,6 +410,7 @@ new value.")
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'widget-doc widget)
(overlay-put overlay 'face widget-documentation-face)
+ (overlay-put overlay 'evaporate t)
(widget-put widget :doc-overlay overlay)))
(defmacro widget-specify-insert (&rest form)
@@ -1286,8 +1289,8 @@ Store the newly created widget in the :children attribute.
The value of the :type attribute should be an unconverted widget type."
(let ((value (widget-get widget :value))
(type (widget-get widget :type)))
- (widget-put widget :children
- (list (widget-create-child-value widget
+ (widget-put widget :children
+ (list (widget-create-child-value widget
(widget-convert type)
value)))))
@@ -3343,8 +3346,8 @@ Here we attempt to define my-list as a choice of either the constant
nil, or a cons-cell containing a sexp and my-lisp. This will not work
because the `choice' widget does not allow recursion.
-Using the `lazy' widget you can overcome this problem, as in this
-example:
+Using the `lazy' widget you can overcome this problem, as in this
+example:
(define-widget 'sexp-list 'lazy
\"A list of sexps.\"
@@ -3353,7 +3356,7 @@ example:
:format "%{%t%}: %v"
;; We don't convert :type because we want to allow recursive
;; datastructures. This is slow, so we should not create speed
- ;; critical widgets by deriving from this.
+ ;; critical widgets by deriving from this.
:convert-widget 'widget-value-convert-widget
:value-create 'widget-type-value-create
:value-get 'widget-child-value-get
diff --git a/lisp/window.el b/lisp/window.el
index 91b91cfb158..188b3acf311 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -36,6 +36,9 @@ of this construct.
However, if a window has become dead, don't get an error,
just refrain from reselecting it."
`(let ((save-selected-window-window (selected-window))
+ ;; It is necessary to save all of these, because calling
+ ;; select-window changes frame-selected-window for whatever
+ ;; frame that window is in.
(save-selected-window-alist
(mapcar (lambda (frame) (list frame (frame-selected-window frame)))
(frame-list))))
@@ -327,8 +330,9 @@ new mode line."
(with-current-buffer (window-buffer)
(if view-mode
(let ((old-info (assq old-w view-return-to-alist)))
- (push (cons new-w (cons (and old-info (car (cdr old-info))) t))
- view-return-to-alist)))
+ (if old-info
+ (push (cons new-w (cons (car (cdr old-info)) t))
+ view-return-to-alist))))
new-w))
(defun split-window-horizontally (&optional arg)
diff --git a/lisp/winner.el b/lisp/winner.el
index aaca331e7b3..e5b48889156 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -1,6 +1,6 @@
;;; winner.el --- Restore old window configurations
-;; Copyright (C) 1997, 1998, 2001 Free Software Foundation. Inc.
+;; Copyright (C) 1997, 1998, 2001, 2004 Free Software Foundation. Inc.
;; Author: Ivar Rummelhoff <ivarru@math.uio.no>
;; Created: 27 Feb 1997
@@ -30,8 +30,8 @@
;; window configuration (i.e. how the frames are partitioned into
;; windows) so that the changes can be "undone" using the command
;; `winner-undo'. By default this one is bound to the key sequence
-;; ctrl-x left. If you change your mind (while undoing), you can
-;; press ctrl-x right (calling `winner-redo'). Even though it uses
+;; ctrl-c left. If you change your mind (while undoing), you can
+;; press ctrl-c right (calling `winner-redo'). Even though it uses
;; some features of Emacs20.3, winner.el should also work with
;; Emacs19.34 and XEmacs20, provided that the installed version of
;; custom is not obsolete.
@@ -474,8 +474,8 @@ In other words, \"undo\" changes in window configuration."
(unless winner-mode-map
(setq winner-mode-map (make-sparse-keymap))
- (define-key winner-mode-map [(control x) left] 'winner-undo)
- (define-key winner-mode-map [(control x) right] 'winner-redo))
+ (define-key winner-mode-map [(control c) left] 'winner-undo)
+ (define-key winner-mode-map [(control c) right] 'winner-redo))
(unless (or (assq 'winner-mode minor-mode-map-alist)
winner-dont-bind-my-keys)
diff --git a/lisp/woman.el b/lisp/woman.el
index d69c631f27b..ba511bca1ae 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -1,6 +1,6 @@
;;; woman.el --- browse UN*X manual pages `wo (without) man'
-;; Copyright (C) 2000, 2002 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2002, 2004 Free Software Foundation, Inc.
;; Author: Francis J. Wright <F.J.Wright@qmul.ac.uk>
;; Maintainer: Francis J. Wright <F.J.Wright@qmul.ac.uk>
@@ -402,6 +402,7 @@
;; Alexander Hinds <ahinds@thegrid.net>
;; Stefan Hornburg <sth@hacon.de>
;; Theodore Jump <tjump@cais.com>
+;; David Kastrup <dak@gnu.org>
;; Paul Kinnucan <paulk@mathworks.com>
;; Jonas Linde <jonas@init.se>
;; Andrew McRae <andrewm@optimation.co.nz>
@@ -438,7 +439,8 @@
"Return concatenated list of FN applied to successive `car' elements of X.
FN must return a list, cons or nil. Useful for splicing into a list."
;; Based on the Standard Lisp function MAPCAN but with args swapped!
- (and x (nconc (funcall fn (car x)) (woman-mapcan fn (cdr x)))))
+ ;; More concise implementation than the recursive one. -- dak
+ (apply #'nconc (mapcar fn x)))
(defun woman-parse-colon-path (paths)
"Explode search path string PATHS into a list of directory names.
@@ -1367,15 +1369,16 @@ The cdr of each alist element is the path-index / filename."
;; is re-processed by `woman-topic-all-completions-merge'.
(let (dir files (path-index 0)) ; indexing starts at zero
(while path
- (setq dir (car path)
- path (cdr path))
+ (setq dir (pop path))
(if (woman-not-member dir path) ; use each directory only once!
- (setq files
- (nconc files
- (woman-topic-all-completions-1 dir path-index))))
+ (push (woman-topic-all-completions-1 dir path-index)
+ files))
(setq path-index (1+ path-index)))
;; Uniquefy topics:
- (woman-topic-all-completions-merge files)))
+ ;; Concate all lists with a single nconc call to
+ ;; avoid retraversing the first lists repeatedly -- dak
+ (woman-topic-all-completions-merge
+ (apply #'nconc files))))
(defun woman-topic-all-completions-1 (dir path-index)
"Return an alist of the man topics in directory DIR with index PATH-INDEX.
@@ -1388,55 +1391,54 @@ of the first `woman-cache-level' elements from the following list:
;; unnecessary. So let us assume that `woman-file-regexp' will
;; filter out any directories, which probably should not be there
;; anyway, i.e. it is a user error!
- (mapcar
- (lambda (file)
- (cons
- (file-name-sans-extension
- (if (string-match woman-file-compression-regexp file)
- (file-name-sans-extension file)
- file))
- (if (> woman-cache-level 1)
- (cons
- path-index
- (if (> woman-cache-level 2)
- (cons file nil))))))
- (directory-files dir nil woman-file-regexp)))
+ ;;
+ ;; Don't sort files: we do that when merging, anyway. -- dak
+ (let (newlst (lst (directory-files dir nil woman-file-regexp t))
+ ;; Make an explicit regexp for stripping extension and
+ ;; compression extension: file-name-sans-extension is a
+ ;; far too costly function. -- dak
+ (ext (format "\\(\\.[^.\\/]*\\)?\\(%s\\)?\\'"
+ woman-file-compression-regexp)))
+ ;; Use a loop instead of mapcar in order to avoid the speed
+ ;; penalty of binding function arguments. -- dak
+ (dolist (file lst newlst)
+ (push
+ (cons
+ (if (string-match ext file)
+ (substring file 0 (match-beginning 0))
+ file)
+ (and (> woman-cache-level 1)
+ (cons
+ path-index
+ (and (> woman-cache-level 2)
+ (list file)))))
+ newlst))))
(defun woman-topic-all-completions-merge (alist)
"Merge the alist ALIST so that the keys are unique.
Also make each path-info component into a list.
\(Note that this function changes the value of ALIST.)"
- ;; Intended to be fast by avoiding recursion and list copying.
- (if (> woman-cache-level 1)
- (let ((newalist alist))
- (while newalist
- (let ((tail newalist) (topic (car (car newalist))))
- ;; Make the path-info into a list:
- (setcdr (car newalist) (list (cdr (car newalist))))
- (while tail
- (while (and tail (not (string= topic (car (car (cdr tail))))))
- (setq tail (cdr tail)))
- (if tail ; merge path-info into (car newalist)
- (let ((path-info (cdr (car (cdr tail)))))
- (if (member path-info (cdr (car newalist)))
- ()
- ;; Make the path-info into a list:
- (nconc (car newalist) (list path-info)))
- (setcdr tail (cdr (cdr tail))))
- ))
- (setq newalist (cdr newalist))))
- alist)
+ ;; Replaces unreadably "optimized" O(n^2) implementation.
+ ;; Instead we use sorting to merge stuff efficiently. -- dak
+ (let (elt newalist)
+ ;; Sort list into reverse order
+ (setq alist (sort alist (lambda(x y) (string< (car y) (car x)))))
+ ;; merge duplicate keys.
+ (if (> woman-cache-level 1)
+ (while alist
+ (setq elt (pop alist))
+ (if (equal (car elt) (caar newalist))
+ (unless (member (cdr elt) (cdar newalist))
+ (setcdr (car newalist) (cons (cdr elt)
+ (cdar newalist))))
+ (setcdr elt (list (cdr elt)))
+ (push elt newalist)))
;; woman-cache-level = 1 => elements are single-element lists ...
- (while (and alist (member (car alist) (cdr alist)))
- (setq alist (cdr alist)))
- (if alist
- (let ((newalist alist) cdr_alist)
- (while (setq cdr_alist (cdr alist))
- (if (not (member (car cdr_alist) (cdr cdr_alist)))
- (setq alist cdr_alist)
- (setcdr alist (cdr cdr_alist)))
- )
- newalist))))
+ (while alist
+ (setq elt (pop alist))
+ (unless (equal (car elt) (caar newalist))
+ (push elt newalist))))
+ newalist))
(defun woman-file-name-all-completions (topic)
"Return an alist of the files in all man directories that match TOPIC."
diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el
index cdb0a63ace6..7d43a10556e 100644
--- a/lisp/x-dnd.el
+++ b/lisp/x-dnd.el
@@ -308,14 +308,13 @@ and must have the format file:file-name or file:///file-name.
The last / in file:/// is part of the file name. ACTION is ignored."
(let* ((f (x-dnd-get-local-file-name uri t)))
- (when f
- (if (file-readable-p f)
- (progn
- (if x-dnd-open-file-other-window
- (find-file-other-window f)
- (find-file f))
- 'private)
- (error "Can not read %s (%s)" f uri)))))
+ (if (and f (file-readable-p f))
+ (progn
+ (if x-dnd-open-file-other-window
+ (find-file-other-window f)
+ (find-file f))
+ 'private)
+ (error "Can not read %s" uri))))
(defun x-dnd-open-file (uri action)
"Open a local or remote file.
@@ -327,7 +326,8 @@ The last / in file://hostname/ is part of the file name."
;; The hostname may be our hostname, in that case, convert to a local
;; file. Otherwise return nil.
(let ((local-file (x-dnd-get-local-file-uri uri)))
- (when local-file (x-dnd-open-local-file local-file action))))
+ (if local-file (x-dnd-open-local-file local-file action)
+ (error "Remote files not supported"))))
(defun x-dnd-handle-moz-url (window action data)
diff --git a/lisp/xml.el b/lisp/xml.el
index 408c13ab39b..03ef6346c70 100644
--- a/lisp/xml.el
+++ b/lisp/xml.el
@@ -27,13 +27,13 @@
;; This file contains a somewhat incomplete non-validating XML parser. It
;; parses a file, and returns a list that can be used internally by
-;; any other lisp libraries.
+;; any other Lisp libraries.
;;; FILE FORMAT
;; The document type declaration may either be ignored or (optionally)
;; parsed, but currently the parsing will only accept element
-;; declarations. The XML file is assumed to be well-formed. In case
+;; declarations. The XML file is assumed to be well-formed. In case
;; of error, the parsing stops and the XML file is shown where the
;; parsing stopped.
;;
@@ -44,7 +44,7 @@
;; <node2 attr3="name3" attr4="name4">value2</node2>
;; <node3 attr5="name5" attr6="name6">value3</node3>
;; </node1>
-;; Of course, the name of the nodes and attributes can be anything. There can
+;; Of course, the name of the nodes and attributes can be anything. There can
;; be any number of attributes (or none), as well as any number of children
;; below the nodes.
;;
@@ -86,7 +86,18 @@
(defsubst xml-node-name (node)
"Return the tag associated with NODE.
-The tag is a lower-case symbol."
+Without namespace-aware parsing, the tag is a symbol.
+
+With namespace-aware parsing, the tag is a cons of a string
+representing the uri of the namespace with the local name of the
+tag. For example,
+
+ <foo>
+
+would be represented by
+
+ '(\"\" . \"foo\")."
+
(car node))
(defsubst xml-node-attributes (node)
@@ -101,17 +112,17 @@ This is a list of nodes, and it can be nil."
(defun xml-get-children (node child-name)
"Return the children of NODE whose tag is CHILD-NAME.
-CHILD-NAME should be a lower case symbol."
+CHILD-NAME should match the value returned by `xml-node-name'."
(let ((match ()))
(dolist (child (xml-node-children node))
- (if child
- (if (equal (xml-node-name child) child-name)
- (push child match))))
+ (if (and (listp child)
+ (equal (xml-node-name child) child-name))
+ (push child match)))
(nreverse match)))
(defun xml-get-attribute-or-nil (node attribute)
"Get from NODE the value of ATTRIBUTE.
-Return `nil' if the attribute was not found.
+Return nil if the attribute was not found.
See also `xml-get-attribute'."
(cdr (assoc attribute (xml-node-attributes node))))
@@ -236,7 +247,8 @@ If PARSE-NS is non-nil, then QNAMES are expanded."
(nreverse xml)))))))
(defun xml-maybe-do-ns (name default xml-ns)
- "Perform any namespace expansion. NAME is the name to perform the expansion on.
+ "Perform any namespace expansion.
+NAME is the name to perform the expansion on.
DEFAULT is the default namespace. XML-NS is a cons of namespace
names to uris. When namespace-aware parsing is off, then XML-NS
is nil.
@@ -325,10 +337,8 @@ Returns one of:
(push (cons (cdar attr) (intern (concat ":" (cdr attr))))
xml-ns))))
- ;; expand element names
- (setq node-name (list (xml-maybe-do-ns node-name "" xml-ns)))
+ (setq children (list attrs (xml-maybe-do-ns node-name "" xml-ns)))
- (setq children (list attrs node-name))
;; is this an empty element ?
(if (looking-at "/>")
(progn
@@ -383,8 +393,8 @@ Returns one of:
(error "XML: Invalid character")))))
(defun xml-parse-attlist (&optional xml-ns)
- "Return the attribute-list after point. Leave point at the
-first non-blank character after the tag."
+ "Return the attribute-list after point.
+Leave point at the first non-blank character after the tag."
(let ((attlist ())
end-pos name)
(skip-syntax-forward " ")
@@ -575,7 +585,7 @@ This follows the rule [28] in the XML specifications."
;; Fixme: Take declared entities from the DTD when they're available.
(defun xml-substitute-entity (match)
- "Subroutine of xml-substitute-special."
+ "Subroutine of `xml-substitute-special'."
(save-match-data
(let ((match1 (match-string 1 str)))
(cond ((string= match1 "lt") "<")
@@ -612,9 +622,15 @@ This follows the rule [28] in the XML specifications."
;;**
;;*******************************************************************
-(defun xml-debug-print (xml)
+(defun xml-debug-print (xml &optional indent-string)
+ "Outputs the XML in the current buffer.
+XML can be a tree or a list of nodes.
+The first line is indented with the optional INDENT-STRING."
+ (setq indent-string (or indent-string ""))
(dolist (node xml)
- (xml-debug-print-internal node "")))
+ (xml-debug-print-internal node indent-string)))
+
+(defalias 'xml-print 'xml-debug-print)
(defun xml-debug-print-internal (xml indent-string)
"Outputs the XML tree in the current buffer.
@@ -629,24 +645,28 @@ The first line is indented with INDENT-STRING."
(insert ?\ (symbol-name (caar attlist)) "=\"" (cdar attlist) ?\")
(setq attlist (cdr attlist)))
- (insert ?>)
-
(setq tree (xml-node-children tree))
- ;; output the children
- (dolist (node tree)
- (cond
- ((listp node)
- (insert ?\n)
- (xml-debug-print-internal node (concat indent-string " ")))
- ((stringp node) (insert node))
- (t
- (error "Invalid XML tree"))))
-
- (insert ?\n indent-string
- ?< ?/ (symbol-name (xml-node-name xml)) ?>)))
+ (if (null tree)
+ (insert ?/ ?>)
+ (insert ?>)
+
+ ;; output the children
+ (dolist (node tree)
+ (cond
+ ((listp node)
+ (insert ?\n)
+ (xml-debug-print-internal node (concat indent-string " ")))
+ ((stringp node) (insert node))
+ (t
+ (error "Invalid XML tree"))))
+
+ (when (not (and (null (cdr tree))
+ (stringp (car tree))))
+ (insert ?\n indent-string))
+ (insert ?< ?/ (symbol-name (xml-node-name xml)) ?>))))
(provide 'xml)
-;;; arch-tag: 5864b283-5a68-4b59-a20d-36a72b353b9b
+;; arch-tag: 5864b283-5a68-4b59-a20d-36a72b353b9b
;;; xml.el ends here